diff options
Diffstat (limited to 'skr')
| -rw-r--r-- | skr/Makefile | 43 | ||||
| -rw-r--r-- | skr/acmproc.skr | 155 | ||||
| -rw-r--r-- | skr/base.skr | 464 | ||||
| -rw-r--r-- | skr/context.skr | 1380 | ||||
| -rw-r--r-- | skr/french.skr | 19 | ||||
| -rw-r--r-- | skr/html.skr | 2251 | ||||
| -rw-r--r-- | skr/html4.skr | 165 | ||||
| -rw-r--r-- | skr/jfp.skr | 317 | ||||
| -rw-r--r-- | skr/latex-simple.skr | 101 | ||||
| -rw-r--r-- | skr/latex.skr | 1780 | ||||
| -rw-r--r-- | skr/letter.skr | 146 | ||||
| -rw-r--r-- | skr/lncs.skr | 147 | ||||
| -rw-r--r-- | skr/scribe.skr | 229 | ||||
| -rw-r--r-- | skr/sigplan.skr | 155 | ||||
| -rw-r--r-- | skr/skribe.skr | 76 | ||||
| -rw-r--r-- | skr/slide.skr | 664 | ||||
| -rw-r--r-- | skr/web-article.skr | 230 | ||||
| -rw-r--r-- | skr/web-book.skr | 107 | ||||
| -rw-r--r-- | skr/xml.skr | 111 |
19 files changed, 0 insertions, 8540 deletions
diff --git a/skr/Makefile b/skr/Makefile deleted file mode 100644 index dcc3e77..0000000 --- a/skr/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/skr/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:21:20 2003 */ -#* Last change : Wed May 18 15:34:21 2005 (serrano) */ -#* Copyright : 2003-05 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Skribe SKR Makefile */ -#*=====================================================================*/ -include ../etc/Makefile.config -include ../etc/$(SYSTEM)/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* POPULATION */ -#*---------------------------------------------------------------------*/ -POPULATION= acmproc.skr sigplan.skr jfp.skr \ - slide.skr web-book.skr web-article.skr \ - base.skr latex.skr scribe.skr xml.skr \ - html.skr html4.skr lncs.skr skribe.skr \ - letter.skr french.skr latex-simple.skr context.skr Makefile - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo $(POPULATION:%=skr/%) - -#*---------------------------------------------------------------------*/ -#* Install/Uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: $(DESTDIR)$(INSTALL_SKRDIR) - cp *.skr $(DESTDIR)$(INSTALL_SKRDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_SKRDIR)/* - -uninstall: - -$(DESTDIR)$(INSTALL_SKRDIR): - mkdir -p $(DESTDIR)$(INSTALL_SKRDIR) && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR) - diff --git a/skr/acmproc.skr b/skr/acmproc.skr deleted file mode 100644 index 4accc7c..0000000 --- a/skr/acmproc.skr +++ /dev/null @@ -1,155 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/acmproc.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for ACMPROC articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le - 'documentclass - "\\documentclass[letterpaper]{acmproc}") - ;; &latex-author - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (printf "\\numberofauthors{~a}\n\\author{\n" - (if (pair? body) (length body) 1)))) - :action (lambda (n e) - (let ((body (markup-body n))) - (for-each (lambda (a) - (display "\\alignauthor\n") - (output a e)) - (if (pair? body) body (list body))))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (writer-action old-author))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category le - :options '(:index :section :subsection) - :before (lambda (n e) - (display "\\category{") - (display (markup-option n :index)) - (display "}") - (display "{") - (display (markup-option n :section)) - (display "}") - (display "{") - (display (markup-option n :subsection)) - (display "}\n[")) - :after "]\n") - (markup-writer '&acm-terms le - :before "\\terms{" - :after "}") - (markup-writer '&acm-keywords le - :before "\\keywords{" - :after "}") - (markup-writer '&acm-copyright le - :action (lambda (n e) - (display "\\conferenceinfo{") - (output (markup-option n :conference) e) - (display ",} {") - (output (markup-option n :location) e) - (display "}\n") - (display "\\CopyrightYear{") - (output (markup-option n :year) e) - (display "}\n") - (display "\\crdata{") - (output (markup-option n :crdata) e) - (display "}\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-acmproc-abstract he - :action (lambda (n e) - (let* ((ebg (engine-custom e 'abstract-background)) - (bg (or (and (string? ebg) - (> (string-length ebg) 0)) - ebg - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e)))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category :action #f) - (markup-writer '&acm-terms :action #f) - (markup-writer '&acm-keywords :action #f) - (markup-writer '&acm-copyright :action #f)) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key (class "abstract") postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-acmproc-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :class class :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* acm-category ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-category #!rest opt #!key index section subsection) - (new markup - (markup '&acm-category) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-terms ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-terms #!rest opt) - (new markup - (markup '&acm-terms) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-keywords ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-keywords #!rest opt) - (new markup - (markup '&acm-keywords) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-copyright ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-copyright #!rest opt #!key conference location year crdata) - (let* ((le (find-engine 'latex)) - (cop (format "\\conferenceinfo{~a,} {~a} -\\CopyrightYear{~a} -\\crdata{~a}\n" conference location year crdata)) - (old (engine-custom le 'predocument))) - (if (string? old) - (engine-custom-set! le 'predocument (string-append cop old)) - (engine-custom-set! le 'predocument cop)))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) 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/french.skr b/skr/french.skr deleted file mode 100644 index 373d076..0000000 --- a/skr/french.skr +++ /dev/null @@ -1,19 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/letter.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* French Skribe style */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'usepackage - (string-append (engine-custom le 'usepackage) - "\\usepackage[french]{babel} -\\usepackage{a4}"))) diff --git a/skr/html.skr b/skr/html.skr deleted file mode 100644 index ebac5f2..0000000 --- a/skr/html.skr +++ /dev/null @@ -1,2251 +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-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 " -- ") - ;; 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-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-file ... */ -;*---------------------------------------------------------------------*/ -(define html-file - (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-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) - (display "<li") - (html-class item) - (display ">") - (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) - (display "<li") - (html-class item) - (display ">") - (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/jfp.skr b/skr/jfp.skr deleted file mode 100644 index 60b40f2..0000000 --- a/skr/jfp.skr +++ /dev/null @@ -1,317 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/jfp.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for JFP articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass{jfp}") - (engine-custom-set! le 'hyperref #f) - ;; &latex-author - (markup-writer '&latex-author le - :action (lambda (n e) - (define (&latex-subauthor) - (let* ((d (ast-document n)) - (sa (and (is-markup? d 'document) - (markup-option d :head-author)))) - (if sa - (begin - (display "[") - (output sa e) - (display "]"))))) - (define (&latex-author-1 n) - (display "\\author") - (&latex-subauthor) - (display "{\n") - (output n e) - (display "}\n")) - (define (&latex-author-n n) - (display "\\author") - (&latex-subauthor) - (display "{\n") - (output (car n) e) - (for-each (lambda (a) - (display "\\and ") - (output a e)) - (cdr n)) - (display "}\n")) - (let ((body (markup-body n))) - (cond - ((is-markup? body 'author) - (&latex-author-1 body)) - ((and (list? body) - (every? (lambda (b) (is-markup? b 'author)) - body)) - (&latex-author-n body)) - (else - (skribe-error 'author - "Illegal `jfp' author" - body)))))) - ;; title - (markup-writer '&latex-title le - :before (lambda (n e) - (let* ((d (ast-document n)) - (st (and (is-markup? d 'document) - (markup-option d :head-title)))) - (if st - (begin - (display "\\title[") - (output st e) - (display "]{")) - (display "\\title{")))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (aff (markup-option n :affiliation)) - (addr (markup-option n :address)) - (email (markup-option n :email))) - (if name - (begin - (output name e) - (display "\\\\\n"))) - (if aff - (begin - (output aff e) - (display "\\\\\n"))) - (if addr - (begin - (if (pair? addr) - (for-each (lambda (a) - (output a e) - (display "\\\\\n")) - addr) - (begin - (output addr e) - (display "\\\\\n"))))) - (if email - (begin - (display "\\email{") - (output email e) - (display "}\\\\\n"))))))) - ;; bib-ref - (markup-writer 'bib-ref le - :options '(:bib :text :key) - :before "(" - :action (lambda (n e) - (let ((be (handle-ast (markup-body n)))) - (if (is-markup? be '&bib-entry) - (let ((a (markup-option be 'author)) - (y (markup-option be 'year))) - (cond - ((and (is-markup? a '&bib-entry-author) - (is-markup? y '&bib-entry-year)) - (let ((ba (markup-body a))) - (if (not (string? ba)) - (output ba e) - (let* ((s1 (pregexp-replace* " and " - ba - " \\& ")) - (s2 (pregexp-replace* ", [^ ]+" - s1 - ""))) - (output s2 e) - (display ", ") - (output y e))))) - ((is-markup? y '&bib-entry-year) - (skribe-error 'bib-ref - "Missing `name' entry" - (markup-ident be))) - (else - (let ((ba (markup-body a))) - (if (not (string? ba)) - (output ba e) - (let* ((s1 (pregexp-replace* " and " - ba - " \\& ")) - (s2 (pregexp-replace* ", [^ ]+" - s1 - ""))) - (output s2 e))))))) - (skribe-error 'bib-ref - "Illegal bib-ref" - (markup-ident be))))) - :after ")") - ;; bib-ref/text - (markup-writer 'bib-ref le - :options '(:bib :text :key) - :predicate (lambda (n e) - (markup-option n :key)) - :action (lambda (n e) - (output (markup-option n :key) e))) - ;; &the-bibliography - (markup-writer '&the-bibliography le - :before (lambda (n e) - (display "{% -\\sloppy -\\sfcode`\\.=1000\\relax -\\newdimen\\bibindent -\\bibindent=0em -\\begin{list}{}{% - \\settowidth\\labelwidth{[]}% - \\leftmargin\\labelwidth - \\advance\\leftmargin\\labelsep - \\advance\\leftmargin\\bibindent - \\itemindent -\\bibindent - \\listparindent \\itemindent - }%\n")) - :after (lambda (n e) - (display "\n\\end{list}}\n"))) - ;; bib-entry - (markup-writer '&bib-entry le - :options '(:title) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n") - ;; %bib-entry-title - (markup-writer '&bib-entry-title le - :action (lambda (n e) - (output (markup-body n) e))) - ;; %bib-entry-body - (markup-writer '&bib-entry-body le - :action (lambda (n e) - (define (output-fields descr) - (display "\\item[") - (let loop ((descr descr) - (pending #f) - (armed #f) - (first #t)) - (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 - #f) - (let ((o2 (caddr (car descr)))) - (loop (cons o2 (cdr descr)) - pending - armed - #f)))) - (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 #f)) - (loop (cdr descr) pending armed #f))))) - ((symbol? (car descr)) - (let ((o (markup-option n (car descr)))) - (if o - (begin - (if (and armed pending) - (output pending e)) - (output o e) - (if first - (display "]")) - (loop (cdr descr) #f #t #f)) - (loop (cdr descr) pending armed #f)))) - ((null? (cdr descr)) - (output (car descr) e)) - ((string? (car descr)) - (loop (cdr descr) - (if pending pending (car descr)) - armed - #f)) - (else - (skribe-error 'output-bib-fields - "Illegal description" - (car descr)))))) - (output-fields - (case (markup-option n 'kind) - ((techreport) - `(author (" (" year ")") " " (or title url) ". " - number ", " institution ", " - address ", " month ", " - ("pp. " pages) ".")) - ((article) - `(author (" (" year ")") " " (or title url) ". " - journal ", " volume ", " ("(" number ")") ", " - address ", " month ", " - ("pp. " pages) ".")) - ((inproceedings) - `(author (" (" year ")") " " (or title url) ". " - book(or title url) ", " series ", " ("(" number ")") ", " - address ", " month ", " - ("pp. " pages) ".")) - ((book) - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ", " ("pp. " pages) ".")) - ((phdthesis) - '(author (" (" year ")") " " (or title url) ". " type ", " - school ", " address - ", " month ".")) - ((misc) - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ".")) - (else - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ", " ("pp. " pages) ".")))))) - ;; abstract - (markup-writer 'jfp-abstract le - :options '(postscript) - :before "\\begin{abstract}\n" - :after "\\end{abstract}\n")) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-jfp-abstract he - :action (lambda (n e) - (let* ((bg (engine-custom e 'abstract-background)) - (exp (p (if bg - (center (color :bg bg :width 90. - (it (markup-body n)))) - (it (markup-body n)))))) - (skribe-eval exp e))))) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (new markup - (markup 'jfp-abstract) - (body (p (the-body opt)))) - (let ((a (new markup - (markup '&html-jfp-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (section :title "References" :class "references" - :number (not (engine-format? "latex")) - (font :size -1 (the-bibliography))))) - 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/letter.skr b/skr/letter.skr deleted file mode 100644 index 17a0058..0000000 --- a/skr/letter.skr +++ /dev/null @@ -1,146 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/letter.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe style for letters */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* document */ -;*---------------------------------------------------------------------*/ -(define %letter-document document) - -(define-markup (document #!rest opt - #!key (ident #f) (class "letter") - where date author - &skribe-eval-location) - (let* ((ubody (the-body opt)) - (body (list (new markup - (markup '&letter-where) - (loc &skribe-eval-location) - (options `((:where ,where) - (:date ,date) - (:author ,author)))) - ubody))) - (apply %letter-document - :author #f :title #f - (append (apply append - (the-options opt :where :date :author :title)) - body)))) - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") - (engine-custom-set! le 'maketitle #f) - ;; &letter-where - (markup-writer '&letter-where le - :before "\\begin{raggedright}\n" - :action (lambda (n e) - (let* ((w (markup-option n :where)) - (d (markup-option n :date)) - (a (markup-option n :author)) - (hd (if (and w d) - (list w ", " d) - (or w d))) - (ne (copy-engine 'author e))) - ;; author - (markup-writer 'author ne - :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) - :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) - (when hd - (display "\\hfill ") - (output hd e) - (set! hd #f)) - (display "\\\\\n")) - ;; name - (if name (row name)) - ;; 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))))) - ;; emit the author - (if a - (output a ne) - (output hd e)))) - :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) - -;*---------------------------------------------------------------------*/ -;* HTML configuration */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - ;; &letter-where - (markup-writer '&letter-where he - :before "<table width=\"100%\">\n" - :action (lambda (n e) - (let* ((w (markup-option n :where)) - (d (markup-option n :date)) - (a (markup-option n :author)) - (hd (if (and w d) - (list w ", " d) - (or w d))) - (ne (copy-engine 'author e))) - ;; author - (markup-writer 'author ne - :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) - :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) - (display "<tr><td align='left'>") - (output n e) - (when hd - (display "</td><td align='right'>") - (output hd e) - (set! hd #f)) - (display "</td></tr>\n")) - ;; name - (if name (row name)) - ;; 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))))) - ;; emit the author - (if a - (output a ne) - (output hd e)))) - :after "</table>\n<hr>\n\n")) - - diff --git a/skr/lncs.skr b/skr/lncs.skr deleted file mode 100644 index 4668404..0000000 --- a/skr/lncs.skr +++ /dev/null @@ -1,147 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/lncs.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for LNCS articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass{llncs}") - ;; &latex-author - (markup-writer '&latex-author le - :action (lambda (n e) - (define (&latex-inst-body n) - (let ((affiliation (markup-option n :affiliation)) - (address (markup-option n :address))) - (when affiliation (output affiliation e) (display ", ")) - (when address - (for-each (lambda (a) (output a e) (display " ")) - address) - (newline)))) - (define (&latex-inst-n i) - (display "\\institute{\n") - (&latex-inst-body (car i)) - (for-each (lambda (n) - (display "\\and\n") - (&latex-inst-body n)) - (cdr i)) - (display "}\n")) - (define (&latex-author-1 n) - (display "\\author{\n") - (output n e) - (display "}\n")) - (define (&latex-author-n n) - (display "\\author{\n") - (output (car n) e) - (for-each (lambda (a) - (display " and ") - (output a e)) - (cdr n)) - (display "}\n")) - (let ((body (markup-body n))) - (cond - ((is-markup? body 'author) - (markup-option-add! n 'inst 1) - (&latex-author-1 body) - (&latex-inst-n (list body))) - ((and (list? body) - (every? (lambda (b) (is-markup? b 'author)) - body)) - (define (institute=? n1 n2) - (let ((aff1 (markup-option n1 :affiliation)) - (add1 (markup-option n1 :address)) - (aff2 (markup-option n2 :affiliation)) - (add2 (markup-option n2 :address))) - (and (equal? aff1 aff2) (equal? add1 add2)))) - (define (search-institute n i j) - (cond - ((null? i) - #f) - ((institute=? n (car i)) - j) - (else - (search-institute n (cdr i) (- j 1))))) - (if (null? (cdr body)) - (begin - (markup-option-add! (car body) 'inst 1) - (&latex-author-1 (car body)) - (&latex-inst-n body)) - ;; collect the institutes - (let loop ((ns body) - (is '()) - (j 1)) - (if (null? ns) - (begin - (&latex-author-n body) - (&latex-inst-n (reverse! is))) - (let* ((n (car ns)) - (si (search-institute n is (- j 1)))) - (if (integer? si) - (begin - (markup-option-add! n 'inst si) - (loop (cdr ns) is j)) - (begin - (markup-option-add! n 'inst j) - (loop (cdr ns) - (cons n is) - (+ 1 j))))))))) - (else - (skribe-error 'author - "Illegal `lncs' author" - body)))))) - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (inst (markup-option n 'inst))) - (if name (output name e)) - (if title (output title e)) - (if inst (printf "\\inst{~a}\n" inst))))))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-lncs-abstract he - :action (lambda (n e) - (let* ((bg (or (engine-custom e 'abstract-background) - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e))))) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-lncs-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/skr/scribe.skr b/skr/scribe.skr deleted file mode 100644 index d9e3bb8..0000000 --- a/skr/scribe.skr +++ /dev/null @@ -1,229 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/scribe.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 29 10:07:21 2003 */ -;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Scribe Compatibility kit */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* style ... */ -;*---------------------------------------------------------------------*/ -(define (style . styles) - (define (load-style style) - (let ((name (cond - ((string? style) - style) - ((symbol? style) - (string-append (symbol->string style) ".scr"))))) - (skribe-load name :engine *skribe-engine*))) - (for-each load-style styles)) - -;*---------------------------------------------------------------------*/ -;* chapter ... */ -;*---------------------------------------------------------------------*/ -(define skribe-chapter chapter) - -(define-markup (chapter #!rest opt #!key title subtitle split number toc file) - (apply skribe-chapter - :title (or title subtitle) - :number number - :toc toc - :file file - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* table-of-contents ... */ -;*---------------------------------------------------------------------*/ -(define-markup (table-of-contents #!rest opts #!key chapter section subsection) - (apply toc opts)) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(define skribe-frame frame) - -(define-markup (frame #!rest opt #!key width margin) - (apply skribe-frame - :width (if (real? width) (* 100 width) width) - :margin margin - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* copyright ... */ -;*---------------------------------------------------------------------*/ -(define (copyright) - (symbol 'copyright)) - -;*---------------------------------------------------------------------*/ -;* sect ... */ -;*---------------------------------------------------------------------*/ -(define (sect) - (symbol 'section)) - -;*---------------------------------------------------------------------*/ -;* euro ... */ -;*---------------------------------------------------------------------*/ -(define (euro) - (symbol 'euro)) - -;*---------------------------------------------------------------------*/ -;* tab ... */ -;*---------------------------------------------------------------------*/ -(define (tab) - (char #\tab)) - -;*---------------------------------------------------------------------*/ -;* space ... */ -;*---------------------------------------------------------------------*/ -(define (space) - (char #\space)) - -;*---------------------------------------------------------------------*/ -;* print-bibliography ... */ -;*---------------------------------------------------------------------*/ -(define-markup (print-bibliography #!rest opts - #!key all (sort bib-sort/authors)) - (the-bibliography all sort)) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(define skribe-linebreak linebreak) - -(define-markup (linebreak . lnum) - (cond - ((null? lnum) - (skribe-linebreak)) - ((string? (car lnum)) - (skribe-linebreak (string->number (car lnum)))) - (else - (skribe-linebreak (car lnum))))) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;*---------------------------------------------------------------------*/ -(define skribe-ref ref) - -(define-markup (ref #!rest opts - #!key scribe url id page figure mark - chapter section subsection subsubsection subsubsection - bib bib+ number) - (let ((bd (the-body opts)) - (args (apply append (the-options opts :id)))) - (if id (set! args (cons* :mark id args))) - (if (pair? bd) (set! args (cons* :text bd args))) - (apply skribe-ref args))) - -;*---------------------------------------------------------------------*/ -;* indexes ... */ -;*---------------------------------------------------------------------*/ -(define *scribe-indexes* - (list (cons "theindex" (make-index "theindex")))) - -(define skribe-index index) -(define skribe-make-index make-index) - -(define-markup (make-index index) - (let ((i (skribe-make-index index))) - (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) - i)) - -(define-markup (index #!rest opts #!key note index shape) - (let ((i (if (not index) - "theindex" - (let ((i (assoc index *scribe-indexes*))) - (if (pair? i) - (cdr i) - (make-index index)))))) - (apply skribe-index :note note :index i :shape shape (the-body opts)))) - -(define-markup (print-index #!rest opts - #!key split (char-offset 0) (header-limit 100)) - (apply the-index - :split split - :char-offset char-offset - :header-limit header-limit - (map (lambda (i) - (let ((c (assoc i *scribe-indexes*))) - (if (pair? c) - (cdr c) - (skribe-error 'the-index "Unknown index" i)))) - (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* format? */ -;*---------------------------------------------------------------------*/ -(define (scribe-format? fmt) #f) - -;*---------------------------------------------------------------------*/ -;* scribe-url ... */ -;*---------------------------------------------------------------------*/ -(define (scribe-url) (skribe-url)) - -;*---------------------------------------------------------------------*/ -;* Various configurations */ -;*---------------------------------------------------------------------*/ -(define *scribe-background* #f) -(define *scribe-foreground* #f) -(define *scribe-tbackground* #f) -(define *scribe-tforeground* #f) -(define *scribe-title-font* #f) -(define *scribe-author-font* #f) -(define *scribe-chapter-numbering* #f) -(define *scribe-footer* #f) -(define *scribe-prgm-color* #f) - -;*---------------------------------------------------------------------*/ -;* prgm ... */ -;*---------------------------------------------------------------------*/ -(define-markup (prgm #!rest opts - #!key lnum lnumwidth language bg frame (width 1.) - colors (monospace #t)) - (let* ((w (cond - ((real? width) (* width 100.)) - ((number? width) width) - (else 100.))) - (body (if language - (source :language language (the-body opts)) - (the-body opts))) - (body (if monospace - (prog :line lnum body) - body)) - (body (if bg - (color :width 100. :bg bg body) - body))) - (skribe-frame :width w - :border (if frame 1 #f) - body))) - -;*---------------------------------------------------------------------*/ -;* latex configuration */ -;*---------------------------------------------------------------------*/ -(define *scribe-tex-predocument* #f) - -;*---------------------------------------------------------------------*/ -;* latex-prelude ... */ -;*---------------------------------------------------------------------*/ -(define (latex-prelude e) - (if (engine-format? "latex" e) - (begin - (if *scribe-tex-predocument* - (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) - -;*---------------------------------------------------------------------*/ -;* html-prelude ... */ -;*---------------------------------------------------------------------*/ -(define (html-prelude e) - (if (engine-format? "html" e) - (begin - #f))) - -;*---------------------------------------------------------------------*/ -;* prelude */ -;*---------------------------------------------------------------------*/ -(let ((p (user-prelude))) - (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/skr/sigplan.skr b/skr/sigplan.skr deleted file mode 100644 index 9bdb939..0000000 --- a/skr/sigplan.skr +++ /dev/null @@ -1,155 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/sigplan.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Wed May 18 16:00:38 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for ACMPROC articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le - 'documentclass - "\\documentclass[twocolumns]{sigplanconf}") - ;; &latex-author - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (printf "\\authorinfo{\n" - (if (pair? body) (length body) 1)))) - :action (lambda (n e) - (let ((body (markup-body n))) - (for-each (lambda (a) - (display "}\n\\authorinfo{") - (output a e)) - (if (pair? body) body (list body))))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (writer-action old-author))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category le - :options '(:index :section :subsection) - :before (lambda (n e) - (display "\\category{") - (display (markup-option n :index)) - (display "}") - (display "{") - (display (markup-option n :section)) - (display "}") - (display "{") - (display (markup-option n :subsection)) - (display "}\n[")) - :after "]\n") - (markup-writer '&acm-terms le - :before "\\terms{" - :after "}") - (markup-writer '&acm-keywords le - :before "\\keywords{" - :after "}") - (markup-writer '&acm-copyright le - :action (lambda (n e) - (display "\\conferenceinfo{") - (output (markup-option n :conference) e) - (display ",} {") - (output (markup-option n :location) e) - (display "}\n") - (display "\\copyrightyear{") - (output (markup-option n :year) e) - (display "}\n") - (display "\\copyrightdata{") - (output (markup-option n :crdata) e) - (display "}\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-acmproc-abstract he - :action (lambda (n e) - (let* ((ebg (engine-custom e 'abstract-background)) - (bg (or (and (string? ebg) - (> (string-length ebg) 0)) - ebg - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e)))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category :action #f) - (markup-writer '&acm-terms :action #f) - (markup-writer '&acm-keywords :action #f) - (markup-writer '&acm-copyright :action #f)) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-acmproc-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* acm-category ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-category #!rest opt #!key index section subsection) - (new markup - (markup '&acm-category) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-terms ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-terms #!rest opt) - (new markup - (markup '&acm-terms) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-keywords ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-keywords #!rest opt) - (new markup - (markup '&acm-keywords) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-copyright ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-copyright #!rest opt #!key conference location year crdata) - (let* ((le (find-engine 'latex)) - (cop (format "\\conferenceinfo{~a,} {~a} -\\CopyrightYear{~a} -\\crdata{~a}\n" conference location year crdata)) - (old (engine-custom le 'predocument))) - (if (string? old) - (engine-custom-set! le 'predocument (string-append cop old)) - (engine-custom-set! le 'predocument cop)))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/skr/skribe.skr b/skr/skribe.skr deleted file mode 100644 index 86425ac..0000000 --- a/skr/skribe.skr +++ /dev/null @@ -1,76 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/skribe.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jan 11 11:23:12 2002 */ -;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */ -;* Copyright : 2002-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The standard Skribe style (always loaded). */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* p ... */ -;*---------------------------------------------------------------------*/ -(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) - (paragraph :ident ident :class class :loc &skribe-eval-location - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* fg ... */ -;*---------------------------------------------------------------------*/ -(define (fg c . body) - (color :fg c body)) - -;*---------------------------------------------------------------------*/ -;* bg ... */ -;*---------------------------------------------------------------------*/ -(define (bg c . body) - (color :bg c body)) - -;*---------------------------------------------------------------------*/ -;* counter ... */ -;* ------------------------------------------------------------- */ -;* This produces a kind of "local enumeration" that is: */ -;* (counting "toto," "tutu," "titi.") */ -;* produces: */ -;* i) toto, ii) tutu, iii) titi. */ -;*---------------------------------------------------------------------*/ -(define-markup (counter #!rest opts #!key (numbering 'roman)) - (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) - (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) - (define (the-roman-number num) - (if (< num (vector-length vroman)) - (list (list "(" (it (vector-ref vroman num)) ") ")) - (skribe-error 'counter - "too many items for roman numbering" - (length items)))) - (define (the-arabic-number num) - (list (list "(" (it (integer->string num)) ") "))) - (define (the-alpha-number num) - (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) - (let ((the-number (case numbering - ((roman) the-roman-number) - ((arabic) the-arabic-number) - ((alpha) the-alpha-number) - (else (skribe-error 'counter - "Illegal numbering" - numbering))))) - (let loop ((num 1) - (items items) - (res '())) - (if (null? items) - (reverse! res) - (loop (+ num 1) - (cdr items) - (cons (list (the-number num) (car items)) res)))))) - -;*---------------------------------------------------------------------*/ -;* q */ -;*---------------------------------------------------------------------*/ -(define-markup (q #!rest opt) - (new markup - (markup 'q) - (options (the-options opt)) - (body (the-body opt)))) - diff --git a/skr/slide.skr b/skr/slide.skr deleted file mode 100644 index f8638ad..0000000 --- a/skr/slide.skr +++ /dev/null @@ -1,664 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/slide.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe style for slides */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* slide-options */ -;*---------------------------------------------------------------------*/ -(define &slide-load-options (skribe-load-options)) - -;*---------------------------------------------------------------------*/ -;* &slide-seminar-predocument ... */ -;*---------------------------------------------------------------------*/ -(define &slide-seminar-predocument - "\\special{landscape} - \\slideframe{none} - \\centerslidesfalse - \\raggedslides[0pt] - \\renewcommand{\\slideleftmargin}{0.2in} - \\renewcommand{\\slidetopmargin}{0.3in} - \\newdimen\\slidewidth \\slidewidth 9in") - -;*---------------------------------------------------------------------*/ -;* &slide-seminar-maketitle ... */ -;*---------------------------------------------------------------------*/ -(define &slide-seminar-maketitle - "\\def\\labelitemi{$\\bullet$} - \\def\\labelitemii{$\\circ$} - \\def\\labelitemiii{$\\diamond$} - \\def\\labelitemiv{$\\cdot$} - \\pagestyle{empty} - \\slideframe{none} - \\centerslidestrue - \\begin{slide} - \\date{} - \\maketitle - \\end{slide} - \\slideframe{none} - \\centerslidesfalse") - -;*---------------------------------------------------------------------*/ -;* &slide-prosper-predocument ... */ -;*---------------------------------------------------------------------*/ -(define &slide-prosper-predocument - "\\slideCaption{}\n") - -;*---------------------------------------------------------------------*/ -;* %slide-the-slides ... */ -;*---------------------------------------------------------------------*/ -(define %slide-the-slides '()) -(define %slide-the-counter 0) -(define %slide-initialized #f) -(define %slide-latex-mode 'seminar) - -;*---------------------------------------------------------------------*/ -;* %slide-initialize! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-initialize!) - (unless %slide-initialized - (set! %slide-initialized #t) - (case %slide-latex-mode - ((seminar) - (%slide-seminar-setup!)) - ((advi) - (%slide-advi-setup!)) - ((prosper) - (%slide-prosper-setup!)) - (else - (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) - -;*---------------------------------------------------------------------*/ -;* slide ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide #!rest opt - #!key - (ident #f) (class #f) - (toc #t) - title (number #t) - (vspace #f) (vfill #f) - (transition #f) - (bg #f) (image #f)) - (%slide-initialize!) - (let ((s (new container - (markup 'slide) - (ident (symbol->string (gensym 'slide))) - (class class) - (required-options '(:title :number :toc)) - (options `((:number - ,(cond - ((number? number) - (set! %slide-the-counter number) - number) - (number - (set! %slide-the-counter - (+ 1 %slide-the-counter)) - %slide-the-counter) - (else - #f))) - (:toc ,toc) - ,@(the-options opt :ident :class :vspace :toc))) - (body (if vspace - (list (slide-vspace vspace) (the-body opt)) - (the-body opt)))))) - (set! %slide-the-slides (cons s %slide-the-slides)) - s)) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;*---------------------------------------------------------------------*/ -(define %slide-old-ref ref) - -(define-markup (ref #!rest opt #!key (slide #f)) - (if (not slide) - (apply %slide-old-ref opt) - (new unresolved - (proc (lambda (n e env) - (cond - ((eq? slide 'next) - (let ((c (assq n %slide-the-slides))) - (if (pair? c) - (handle (cadr c)) - #f))) - ((eq? slide 'prev) - (let ((c (assq n (reverse %slide-the-slides)))) - (if (pair? c) - (handle (cadr c)) - #f))) - ((number? slide) - (let loop ((s %slide-the-slides)) - (cond - ((null? s) - #f) - ((= slide (markup-option (car s) :number)) - (handle (car s))) - (else - (loop (cdr s)))))) - (else - #f))))))) - -;*---------------------------------------------------------------------*/ -;* slide-pause ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-pause) - (new markup - (markup 'slide-pause))) - -;*---------------------------------------------------------------------*/ -;* slide-vspace ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) - (new markup - (markup 'slide-vspace) - (options `((:unit ,unit) ,@(the-options opt :unit))) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* slide-embed ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-embed #!rest opt - #!key - command - (geometry-opt "-geometry") - (geometry #f) (rgeometry #f) - (transient #f) (transient-opt #f) - (alt #f) - &skribe-eval-location) - (if (not (string? command)) - (skribe-error 'slide-embed - "No command provided" - command) - (new markup - (markup 'slide-embed) - (loc &skribe-eval-location) - (required-options '(:alt)) - (options `((:geometry-opt ,geometry-opt) - (:alt ,alt) - ,@(the-options opt :geometry-opt :alt))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-record ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) - (if (not tag) - (skribe-error 'slide-record "Tag missing" tag) - (new markup - (markup 'slide-record) - (ident ident) - (class class) - (options `((:play ,play) ,@(the-options opt))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-play ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-play #!rest opt #!key ident class tag color) - (if (not tag) - (skribe-error 'slide-play "Tag missing" tag) - (new markup - (markup 'slide-play) - (ident ident) - (class class) - (options `((:color ,(if color (skribe-use-color! color) #f)) - ,@(the-options opt :color))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-play* ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-play* #!rest opt - #!key ident class color (scolor "#000000")) - (let ((body (the-body opt))) - (for-each (lambda (lbl) - (match-case lbl - ((?id ?col) - (skribe-use-color! col)))) - body) - (new markup - (markup 'slide-play*) - (ident ident) - (class class) - (options `((:color ,(if color (skribe-use-color! color) #f)) - (:scolor ,(if color (skribe-use-color! scolor) #f)) - ,@(the-options opt :color :scolor))) - (body body)))) - -;*---------------------------------------------------------------------*/ -;* base */ -;*---------------------------------------------------------------------*/ -(let ((be (find-engine 'base))) - (skribe-message "Base slides setup...\n") - ;; slide-pause - (markup-writer 'slide-pause be - :action #f) - ;; slide-vspace - (markup-writer 'slide-vspace be - :options '() - :action #f) - ;; slide-embed - (markup-writer 'slide-embed be - :options '(:alt :geometry-opt) - :action (lambda (n e) - (output (markup-option n :alt) e))) - ;; slide-record - (markup-writer 'slide-record be - :options '(:tag :play) - :action (lambda (n e) - (output (markup-body n) e))) - ;; slide-play - (markup-writer 'slide-play be - :options '(:tag :color) - :action (lambda (n e) - (output (markup-option n :alt) e))) - ;; slide-play* - (markup-writer 'slide-play* be - :options '(:tag :color :scolor) - :action (lambda (n e) - (output (markup-option n :alt) e)))) - -;*---------------------------------------------------------------------*/ -;* slide-body-width ... */ -;*---------------------------------------------------------------------*/ -(define (slide-body-width e) - (let ((w (engine-custom e 'body-width))) - (if (or (number? w) (string? w)) w 95.))) - -;*---------------------------------------------------------------------*/ -;* html-slide-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-slide-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))) - (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" - (html-width (slide-body-width e))) - (if (string? tbg) - (printf "<td bgcolor=\"~a\">" tbg) - (display "<td>")) - (if (string? tfg) - (printf "<font color=\"~a\">" tfg)) - (if title - (begin - (display "<center>") - (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>"))) - (display "</center>\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "</font>")) - (display "</td></tr></tbody></table></center>\n"))) - -;*---------------------------------------------------------------------*/ -;* slide-number ... */ -;*---------------------------------------------------------------------*/ -(define (slide-number) - (length (filter (lambda (n) - (and (is-markup? n 'slide) - (markup-option n :number))) - %slide-the-slides))) - -;*---------------------------------------------------------------------*/ -;* html */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (skribe-message "HTML slides setup...\n") - ;; &html-page-title - (markup-writer '&html-document-title he - :predicate (lambda (n e) %slide-initialized) - :action html-slide-title) - ;; slide - (markup-writer 'slide he - :options '(:title :number :transition :toc :bg) - :before (lambda (n e) - (printf "<a name=\"~a\">" (markup-ident n)) - (display "<br>\n")) - :action (lambda (n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (skribe-eval - (center - (color :width (slide-body-width e) - :bg (or (markup-option n :bg) "#ffffff") - (table :width 100. - (tr (th :align 'left - (list - (if nb - (format "~a / ~a -- " nb - (slide-number))) - t))) - (tr (td (hrule))) - (tr (td :width 100. :align 'left - (markup-body n)))) - (linebreak))) - e))) - :after "<br>") - ;; slide-vspace - (markup-writer 'slide-vspace he - :action (lambda (n e) (display "<br>")))) - -;*---------------------------------------------------------------------*/ -;* latex */ -;*---------------------------------------------------------------------*/ -(define &latex-slide #f) -(define &latex-pause #f) -(define &latex-embed #f) -(define &latex-record #f) -(define &latex-play #f) -(define &latex-play* #f) - -(let ((le (find-engine 'latex))) - ;; slide-vspace - (markup-writer 'slide-vspace le - :options '(:unit) - :action (lambda (n e) - (display "\n\\vspace{") - (output (markup-body n) e) - (printf " ~a}\n\n" (markup-option n :unit)))) - ;; slide-slide - (markup-writer 'slide le - :options '(:title :number :transition :vfill :toc :vspace :image) - :action (lambda (n e) - (if (procedure? &latex-slide) - (&latex-slide n e)))) - ;; slide-pause - (markup-writer 'slide-pause le - :options '() - :action (lambda (n e) - (if (procedure? &latex-pause) - (&latex-pause n e)))) - ;; slide-embed - (markup-writer 'slide-embed le - :options '(:alt :command :geometry-opt :geometry - :rgeometry :transient :transient-opt) - :action (lambda (n e) - (if (procedure? &latex-embed) - (&latex-embed n e)))) - ;; slide-record - (markup-writer 'slide-record le - :options '(:tag :play) - :action (lambda (n e) - (if (procedure? &latex-record) - (&latex-record n e)))) - ;; slide-play - (markup-writer 'slide-play le - :options '(:tag :color) - :action (lambda (n e) - (if (procedure? &latex-play) - (&latex-play n e)))) - ;; slide-play* - (markup-writer 'slide-play* le - :options '(:tag :color :scolor) - :action (lambda (n e) - (if (procedure? &latex-play*) - (&latex-play* n e))))) - -;*---------------------------------------------------------------------*/ -;* %slide-seminar-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-seminar-setup!) - (skribe-message "Seminar slides setup...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base))) - ;; latex configuration - (define (seminar-slide n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (display "\\begin{slide}\n") - (if nb (printf "~a/~a -- " nb (slide-number))) - (output t e) - (display "\\hrule\n")) - (output (markup-body n) e) - (if (markup-option n :vill) (display "\\vfill\n")) - (display "\\end{slide}\n")) - (engine-custom-set! le 'documentclass - "\\documentclass[landscape]{seminar}\n") - (let ((o (engine-custom le 'predocument))) - (engine-custom-set! le 'predocument - (if (string? o) - (string-append &slide-seminar-predocument o) - &slide-seminar-predocument))) - (engine-custom-set! le 'maketitle - &slide-seminar-maketitle) - (engine-custom-set! le 'hyperref-usepackage - "\\usepackage[setpagesize=false]{hyperref}\n") - ;; slide-slide - (set! &latex-slide seminar-slide))) - -;*---------------------------------------------------------------------*/ -;* %slide-advi-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-advi-setup!) - (skribe-message "Generating `Advi Seminar' slides...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base))) - (define (advi-geometry geo) - (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) - (if (pair? r) - (let* ((w (cadr r)) - (w' (string->integer w)) - (w'' (number->string (/ w' *skribe-slide-advi-scale*))) - (h (caddr r)) - (h' (string->integer h)) - (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) - (values "" (string-append w "x" h "+!x+!y"))) - (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) - (if (pair? r) - (let ((w (number->string (/ (string->integer (cadr r)) - *skribe-slide-advi-scale*))) - (h (number->string (/ (string->integer (caddr r)) - *skribe-slide-advi-scale*))) - (x (cadddr r)) - (y (car (cddddr r)))) - (values (string-append "width=" w "cm,height=" h "cm") - "!g")) - (values "" geo)))))) - (define (advi-transition trans) - (cond - ((string? trans) - (printf "\\advitransition{~s}" trans)) - ((and (symbol? trans) - (memq trans '(wipe block slide))) - (printf "\\advitransition{~s}" trans)) - (else - #f))) - ;; latex configuration - (define (advi-slide n e) - (let ((i (markup-option n :image)) - (n (markup-option n :number)) - (t (markup-option n :title)) - (lt (markup-option n :transition)) - (gt (engine-custom e 'transition))) - (if (and i (engine-custom e 'advi)) - (printf "\\advibg[global]{image=~a}\n" - (if (and (pair? i) - (null? (cdr i)) - (string? (car i))) - (car i) - i))) - (display "\\begin{slide}\n") - (advi-transition (or lt gt)) - (if n (printf "~a/~a -- " n (slide-number))) - (output t e) - (display "\\hrule\n")) - (output (markup-body n) e) - (if (markup-option n :vill) (display "\\vfill\n")) - (display "\\end{slide}\n\n\n")) - ;; advi record - (define (advi-record n e) - (display "\\advirecord") - (when (markup-option n :play) (display "[play]")) - (printf "{~a}{" (markup-option n :tag)) - (output (markup-body n) e) - (display "}")) - ;; advi play - (define (advi-play n e) - (display "\\adviplay") - (let ((c (markup-option n :color))) - (when c - (display "[") - (display (skribe-get-latex-color c)) - (display "]"))) - (printf "{~a}" (markup-option n :tag))) - ;; advi play* - (define (advi-play* n e) - (let ((c (skribe-get-latex-color (markup-option n :color))) - (d (skribe-get-latex-color (markup-option n :scolor)))) - (let loop ((lbls (markup-body n)) - (last #f)) - (when last - (display "\\adviplay[") - (display d) - (printf "]{~a}" last)) - (when (pair? lbls) - (let ((lbl (car lbls))) - (match-case lbl - ((?id ?col) - (display "\\adviplay[") - (display (skribe-get-latex-color col)) - (printf "]{" ~a "}" id) - (skribe-eval (slide-pause) e) - (loop (cdr lbls) id)) - (else - (display "\\adviplay[") - (display c) - (printf "]{~a}" lbl) - (skribe-eval (slide-pause) e) - (loop (cdr lbls) lbl)))))))) - (engine-custom-set! le 'documentclass - "\\documentclass{seminar}\n") - (let ((o (engine-custom le 'predocument))) - (engine-custom-set! le 'predocument - (if (string? o) - (string-append &slide-seminar-predocument o) - &slide-seminar-predocument))) - (engine-custom-set! le 'maketitle - &slide-seminar-maketitle) - (engine-custom-set! le 'usepackage - (string-append "\\usepackage{advi}\n" - (engine-custom le 'usepackage))) - ;; slide - (set! &latex-slide advi-slide) - (set! &latex-pause - (lambda (n e) (display "\\adviwait\n"))) - (set! &latex-embed - (lambda (n e) - (let ((geometry-opt (markup-option n :geometry-opt)) - (geometry (markup-option n :geometry)) - (rgeometry (markup-option n :rgeometry)) - (transient (markup-option n :transient)) - (transient-opt (markup-option n :transient-opt)) - (cmd (markup-option n :command))) - (let* ((a (string-append "ephemeral=" - (symbol->string (gensym)))) - (c (cond - (geometry - (string-append cmd " " - geometry-opt " " - geometry)) - (rgeometry - (multiple-value-bind (aopt dopt) - (advi-geometry rgeometry) - (set! a (string-append a "," aopt)) - (string-append cmd " " - geometry-opt " " - dopt))) - (else - cmd))) - (c (if (and transient transient-opt) - (string-append c " " transient-opt " !p") - c))) - (printf "\\adviembed[~a]{~a}\n" a c))))) - (set! &latex-record advi-record) - (set! &latex-play advi-play) - (set! &latex-play* advi-play*))) - -;*---------------------------------------------------------------------*/ -;* %slide-prosper-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-prosper-setup!) - (skribe-message "Generating `Prosper' slides...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base)) - (overlay-count 0)) - ;; transitions - (define (prosper-transition trans) - (cond - ((string? trans) - (printf "[~s]" trans)) - ((eq? trans 'slide) - (printf "[Blinds]")) - ((and (symbol? trans) - (memq trans '(split blinds box wipe dissolve glitter))) - (printf "[~s]" - (string-upcase (symbol->string trans)))) - (else - #f))) - ;; latex configuration - (define (prosper-slide n e) - (let* ((i (markup-option n :image)) - (t (markup-option n :title)) - (lt (markup-option n :transition)) - (gt (engine-custom e 'transition)) - (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) - (lpa (length pa))) - (set! overlay-count 1) - (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) - (display "\\begin{slide}") - (prosper-transition (or lt gt)) - (display "{") - (output t e) - (display "}\n") - (output (markup-body n) e) - (display "\\end{slide}\n") - (if (>= lpa 1) (display "}\n")) - (newline) - (newline))) - (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") - (let* ((cap (engine-custom le 'slide-caption)) - (o (engine-custom le 'predocument)) - (n (if (string? cap) - (format "~a\\slideCaption{~a}\n" - &slide-prosper-predocument - cap) - &slide-prosper-predocument))) - (engine-custom-set! le 'predocument - (if (string? o) (string-append n o) n))) - (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") - ;; writers - (set! &latex-slide prosper-slide) - (set! &latex-pause - (lambda (n e) - (set! overlay-count (+ 1 overlay-count)) - (printf "\\FromSlide{~s}%\n" overlay-count))))) - -;*---------------------------------------------------------------------*/ -;* Setup ... */ -;*---------------------------------------------------------------------*/ -(let* ((opt &slide-load-options) - (p (memq :prosper opt))) - (if (and (pair? p) (pair? (cdr p)) (cadr p)) - ;; prosper - (set! %slide-latex-mode 'prosper) - (let ((a (memq :advi opt))) - (if (and (pair? a) (pair? (cdr a)) (cadr a)) - ;; advi - (set! %slide-latex-mode 'advi))))) - diff --git a/skr/web-article.skr b/skr/web-article.skr deleted file mode 100644 index e33328b..0000000 --- a/skr/web-article.skr +++ /dev/null @@ -1,230 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/web-article.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jan 10 09:09:43 2004 */ -;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ -;* Copyright : 2004 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* A Skribe style for producing web articles */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* &web-article-load-options ... */ -;*---------------------------------------------------------------------*/ -(define &web-article-load-options (skribe-load-options)) - -;*---------------------------------------------------------------------*/ -;* web-article-body-width ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-body-width e) - (let ((w (engine-custom e 'body-width))) - (if (or (number? w) (string? w)) w 98.))) - -;*---------------------------------------------------------------------*/ -;* html-document-title-web ... */ -;*---------------------------------------------------------------------*/ -(define (html-document-title-web 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))) - (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" - (html-width (web-article-body-width e))) - (if (string? tbg) - (printf "<td bgcolor=\"~a\">" tbg) - (display "<td>")) - (if (string? tfg) - (printf "<font color=\"~a\">" tfg)) - (if title - (begin - (display "<center>") - (if (string? tfont) - (begin - (printf "<font ~a><b>" tfont) - (output title e) - (display "</b></font>")) - (begin - (printf "<h1>") - (output title e) - (display "</h1>"))) - (display "</center>\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "</font>")) - (display "</td></tr></tbody></table></center>\n"))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-document-title ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-document-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (id (markup-ident n))) - ;; the title - (printf "<div id=\"~a\" class=\"document-title-title\">\n" - (string-canonicalize id)) - (output title e) - (display "</div>\n") - ;; the authors - (printf "<div id=\"~a\" class=\"document-title-authors\">\n" - (string-canonicalize id)) - (for-each (lambda (a) (output a e)) - (cond - ((is-markup? authors 'author) - (list authors)) - ((list? authors) - authors) - (else - '()))) - (display "</div>\n"))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-author ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-author 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))) - (when name - (printf "<span class=\"document-author-name\" id=\"~a\">" - (string-canonicalize (markup-ident n))) - (output name e) - (display "</span>\n")) - (when title - (printf "<span class=\"document-author-title\" id=\"~a\">" - (string-canonicalize (markup-ident n))) - (output title e) - (display "</span>\n")) - (when affiliation - (printf "<span class=\"document-author-affiliation\" id=\"~a\">" - (string-canonicalize (markup-ident n))) - (output affiliation e) - (display "</span>\n")) - (when (pair? address) - (printf "<span class=\"document-author-address\" id=\"~a\">" - (string-canonicalize (markup-ident n))) - (for-each (lambda (a) - (output a e) - (newline)) - address) - (display "</span>\n")) - (when phone - (printf "<span class=\"document-author-phone\" id=\"~a\">" - (string-canonicalize (markup-ident n))) - (output phone e) - (display "</span>\n")) - (when email - (printf "<span class=\"document-author-email\" id=\"~a\">" - (string-canonicalize (markup-ident n))) - (output email e) - (display "</span>\n")) - (when url - (printf "<span class=\"document-author-url\" id=\"~a\">" - (string-canonicalize (markup-ident n))) - (output url e) - (display "</span>\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML settings */ -;*---------------------------------------------------------------------*/ -(define (web-article-modern-setup he) - (let ((sec (markup-writer-get 'section he)) - (ft (markup-writer-get '&html-footnotes he))) - ;; &html-document-title - (markup-writer '&html-document-title he - :action html-document-title-web) - ;; section - (markup-writer 'section he - :options 'all - :before "<br>" - :action (lambda (n e) - (let ((e1 (make-engine 'html-web :delegate e)) - (bg (engine-custom he 'section-background))) - (markup-writer 'section e1 - :options 'all - :action (lambda (n e2) (output n e sec))) - (skribe-eval - (center (color :width (web-article-body-width e) - :margin 5 :bg bg n)) - e1)))) - ;; &html-footnotes - (markup-writer '&html-footnotes he - :options 'all - :before "<br>" - :action (lambda (n e) - (let ((e1 (make-engine 'html-web :delegate e)) - (bg (engine-custom he 'section-background)) - (fg (engine-custom he 'subsection-title-foreground))) - (markup-writer '&html-footnotes e1 - :options 'all - :action (lambda (n e2) - (invoke (writer-action ft) n e))) - (skribe-eval - (center (color :width (web-article-body-width e) - :margin 5 :bg bg :fg fg n)) - e1)))))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-setup ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-setup he) - (let ((sec (markup-writer-get 'section he)) - (ft (markup-writer-get '&html-footnotes he))) - ;; &html-document-title - (markup-writer '&html-document-title he - :before (lambda (n e) - (printf "<div id=\"~a\" class=\"document-title\">\n" - (string-canonicalize (markup-ident n)))) - :action web-article-css-document-title - :after "</div>\n") - ;; author - (markup-writer 'author he - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (printf "<span id=\"~a\" class=\"document-author\">\n" - (string-canonicalize (markup-ident n)))) - :action web-article-css-author - :after "</span\n") - ;; section - (markup-writer 'section he - :options 'all - :before (lambda (n e) - (printf "<div class=\"section\" id=\"~a\">" - (string-canonicalize (markup-ident n)))) - :action (lambda (n e) (output n e sec)) - :after "</div>\n") - ;; &html-footnotes - (markup-writer '&html-footnotes he - :options 'all - :before (lambda (n e) - (printf "<div class=\"footnotes\" id=\"~a\">" - (string-canonicalize (markup-ident n)))) - :action (lambda (n e) - (output n e ft)) - :after "</div>\n"))) - -;*---------------------------------------------------------------------*/ -;* Setup ... */ -;*---------------------------------------------------------------------*/ -(let* ((opt &web-article-load-options) - (p (memq :style opt)) - (css (memq :css opt)) - (he (find-engine 'html))) - (cond - ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) - (web-article-css-setup he)) - ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) - (engine-custom-set! he 'css (cadr css)) - (web-article-css-setup he)) - (else - (web-article-modern-setup he)))) diff --git a/skr/web-book.skr b/skr/web-book.skr deleted file mode 100644 index f907c8b..0000000 --- a/skr/web-book.skr +++ /dev/null @@ -1,107 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/web-book.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 10:54:32 2003 */ -;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe web book style. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* html customization */ -;*---------------------------------------------------------------------*/ -(define he (find-engine 'html)) -(engine-custom-set! he 'main-browsing-extra #f) -(engine-custom-set! he 'chapter-file #t) - -;*---------------------------------------------------------------------*/ -;* main-browsing ... */ -;*---------------------------------------------------------------------*/ -(define main-browsing - (lambda (n e) - ;; search the document - (let ((p (ast-document n))) - (cond - ((document? p) - ;; got it - (let* ((mt (markup-option p :margin-title)) - (r (ref :handle (handle p) - :text (or mt (markup-option p :title)))) - (fx (engine-custom e 'web-book-main-browsing-extra))) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold "main page")))) - (tr :bg (engine-custom e 'background) - (td (apply table :width 100. :border 0 - (tr (td :align 'left - :valign 'top - (bold "top:")) - (td :align 'right - :valign 'top r)) - (if (procedure? fx) - (list (tr (td :width 100. - :colspan 2 - (fx n e)))) - '())))))))) - ((not p) - ;; no document!!! - #f))))) - -;*---------------------------------------------------------------------*/ -;* chapter-browsing ... */ -;*---------------------------------------------------------------------*/ -(define chapter-browsing - (lambda (n e) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (markup-option n :title))))) - (tr :bg (engine-custom e 'background) - (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) - -;*---------------------------------------------------------------------*/ -;* document-browsing ... */ -;*---------------------------------------------------------------------*/ -(define document-browsing - (lambda (n e) - (let ((chap (find1-down (lambda (n) - (is-markup? n 'chapter)) - n))) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (if chap "Chapters" "Sections"))))) - (tr :bg (engine-custom e 'background) - (td (if chap - (toc (handle n) :chapter #t :section #f) - (toc (handle n) :section #t :subsection #t))))))))) - -;*---------------------------------------------------------------------*/ -;* left margin ... */ -;*---------------------------------------------------------------------*/ -(engine-custom-set! he 'left-margin-size 20.) - -(engine-custom-set! he 'left-margin - (lambda (n e) - (let ((d (ast-document n)) - (c (ast-chapter n))) - (list (linebreak 1) - (main-browsing n e) - (if (is-markup? c 'chapter) - (list (linebreak 2) - (chapter-browsing c e)) - #f) - (if (document? d) - (list (linebreak 2) - (document-browsing d e)) - #f))))) - 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)) |