aboutsummaryrefslogtreecommitdiff
path: root/skr
diff options
context:
space:
mode:
Diffstat (limited to 'skr')
-rw-r--r--skr/Makefile43
-rw-r--r--skr/acmproc.skr155
-rw-r--r--skr/base.skr464
-rw-r--r--skr/context.skr1380
-rw-r--r--skr/french.skr19
-rw-r--r--skr/html.skr2251
-rw-r--r--skr/html4.skr165
-rw-r--r--skr/jfp.skr317
-rw-r--r--skr/latex-simple.skr101
-rw-r--r--skr/latex.skr1780
-rw-r--r--skr/letter.skr146
-rw-r--r--skr/lncs.skr147
-rw-r--r--skr/scribe.skr229
-rw-r--r--skr/sigplan.skr155
-rw-r--r--skr/skribe.skr76
-rw-r--r--skr/slide.skr664
-rw-r--r--skr/web-article.skr230
-rw-r--r--skr/web-book.skr107
-rw-r--r--skr/xml.skr111
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 '((#\< "&lt;")
- (#\> "&gt;")
- (#\& "&amp;")
- (#\" "&quot;")
- (#\@ "&#x40;")))
- :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" "&#161;")
- ("cent" "&#162;")
- ("pound" "&#163;")
- ("currency" "&#164;")
- ("yen" "&#165;")
- ("section" "&#167;")
- ("mul" "&#168;")
- ("copyright" "&#169;")
- ("female" "&#170;")
- ("lguillemet" "&#171;")
- ("not" "&#172;")
- ("registered" "&#174;")
- ("degree" "&#176;")
- ("plusminus" "&#177;")
- ("micro" "&#181;")
- ("paragraph" "&#182;")
- ("middot" "&#183;")
- ("male" "&#184;")
- ("rguillemet" "&#187;")
- ("1/4" "&#188;")
- ("1/2" "&#189;")
- ("3/4" "&#190;")
- ("iquestion" "&#191;")
- ("Agrave" "&#192;")
- ("Aacute" "&#193;")
- ("Acircumflex" "&#194;")
- ("Atilde" "&#195;")
- ("Amul" "&#196;")
- ("Aring" "&#197;")
- ("AEligature" "&#198;")
- ("Oeligature" "&#338;")
- ("Ccedilla" "&#199;")
- ("Egrave" "&#200;")
- ("Eacute" "&#201;")
- ("Ecircumflex" "&#202;")
- ("Euml" "&#203;")
- ("Igrave" "&#204;")
- ("Iacute" "&#205;")
- ("Icircumflex" "&#206;")
- ("Iuml" "&#207;")
- ("ETH" "&#208;")
- ("Ntilde" "&#209;")
- ("Ograve" "&#210;")
- ("Oacute" "&#211;")
- ("Ocurcumflex" "&#212;")
- ("Otilde" "&#213;")
- ("Ouml" "&#214;")
- ("times" "&#215;")
- ("Oslash" "&#216;")
- ("Ugrave" "&#217;")
- ("Uacute" "&#218;")
- ("Ucircumflex" "&#219;")
- ("Uuml" "&#220;")
- ("Yacute" "&#221;")
- ("THORN" "&#222;")
- ("szlig" "&#223;")
- ("agrave" "&#224;")
- ("aacute" "&#225;")
- ("acircumflex" "&#226;")
- ("atilde" "&#227;")
- ("amul" "&#228;")
- ("aring" "&#229;")
- ("aeligature" "&#230;")
- ("oeligature" "&#339;")
- ("ccedilla" "&#231;")
- ("egrave" "&#232;")
- ("eacute" "&#233;")
- ("ecircumflex" "&#234;")
- ("euml" "&#235;")
- ("igrave" "&#236;")
- ("iacute" "&#237;")
- ("icircumflex" "&#238;")
- ("iuml" "&#239;")
- ("eth" "&#240;")
- ("ntilde" "&#241;")
- ("ograve" "&#242;")
- ("oacute" "&#243;")
- ("ocurcumflex" "&#244;")
- ("otilde" "&#245;")
- ("ouml" "&#246;")
- ("divide" "&#247;")
- ("oslash" "&#248;")
- ("ugrave" "&#249;")
- ("uacute" "&#250;")
- ("ucircumflex" "&#251;")
- ("uuml" "&#252;")
- ("yacute" "&#253;")
- ("thorn" "&#254;")
- ("ymul" "&#255;")
- ;; Greek
- ("Alpha" "&#913;")
- ("Beta" "&#914;")
- ("Gamma" "&#915;")
- ("Delta" "&#916;")
- ("Epsilon" "&#917;")
- ("Zeta" "&#918;")
- ("Eta" "&#919;")
- ("Theta" "&#920;")
- ("Iota" "&#921;")
- ("Kappa" "&#922;")
- ("Lambda" "&#923;")
- ("Mu" "&#924;")
- ("Nu" "&#925;")
- ("Xi" "&#926;")
- ("Omicron" "&#927;")
- ("Pi" "&#928;")
- ("Rho" "&#929;")
- ("Sigma" "&#931;")
- ("Tau" "&#932;")
- ("Upsilon" "&#933;")
- ("Phi" "&#934;")
- ("Chi" "&#935;")
- ("Psi" "&#936;")
- ("Omega" "&#937;")
- ("alpha" "&#945;")
- ("beta" "&#946;")
- ("gamma" "&#947;")
- ("delta" "&#948;")
- ("epsilon" "&#949;")
- ("zeta" "&#950;")
- ("eta" "&#951;")
- ("theta" "&#952;")
- ("iota" "&#953;")
- ("kappa" "&#954;")
- ("lambda" "&#955;")
- ("mu" "&#956;")
- ("nu" "&#957;")
- ("xi" "&#958;")
- ("omicron" "&#959;")
- ("pi" "&#960;")
- ("rho" "&#961;")
- ("sigmaf" "&#962;")
- ("sigma" "&#963;")
- ("tau" "&#964;")
- ("upsilon" "&#965;")
- ("phi" "&#966;")
- ("chi" "&#967;")
- ("psi" "&#968;")
- ("omega" "&#969;")
- ("thetasym" "&#977;")
- ("piv" "&#982;")
- ;; punctuation
- ("bullet" "&#8226;")
- ("ellipsis" "&#8230;")
- ("weierp" "&#8472;")
- ("image" "&#8465;")
- ("real" "&#8476;")
- ("tm" "&#8482;")
- ("alef" "&#8501;")
- ("<-" "&#8592;")
- ("<--" "&#8592;")
- ("uparrow" "&#8593;")
- ("->" "&#8594;")
- ("-->" "&#8594;")
- ("downarrow" "&#8595;")
- ("<->" "&#8596;")
- ("<-->" "&#8596;")
- ("<+" "&#8629;")
- ("<=" "&#8656;")
- ("<==" "&#8656;")
- ("Uparrow" "&#8657;")
- ("=>" "&#8658;")
- ("==>" "&#8658;")
- ("Downarrow" "&#8659;")
- ("<=>" "&#8660;")
- ("<==>" "&#8660;")
- ;; Mathematical operators
- ("forall" "&#8704;")
- ("partial" "&#8706;")
- ("exists" "&#8707;")
- ("emptyset" "&#8709;")
- ("infinity" "&#8734;")
- ("nabla" "&#8711;")
- ("in" "&#8712;")
- ("notin" "&#8713;")
- ("ni" "&#8715;")
- ("prod" "&#8719;")
- ("sum" "&#8721;")
- ("asterisk" "&#8727;")
- ("sqrt" "&#8730;")
- ("propto" "&#8733;")
- ("angle" "&#8736;")
- ("and" "&#8743;")
- ("or" "&#8744;")
- ("cap" "&#8745;")
- ("cup" "&#8746;")
- ("integral" "&#8747;")
- ("therefore" "&#8756;")
- ("models" "|=")
- ("vdash" "|-")
- ("dashv" "-|")
- ("sim" "&#8764;")
- ("cong" "&#8773;")
- ("approx" "&#8776;")
- ("neq" "&#8800;")
- ("equiv" "&#8801;")
- ("le" "&#8804;")
- ("ge" "&#8805;")
- ("subset" "&#8834;")
- ("supset" "&#8835;")
- ("nsupset" "&#8835;")
- ("subseteq" "&#8838;")
- ("supseteq" "&#8839;")
- ("oplus" "&#8853;")
- ("otimes" "&#8855;")
- ("perp" "&#8869;")
- ("mid" "|")
- ("lceil" "&#8968;")
- ("rceil" "&#8969;")
- ("lfloor" "&#8970;")
- ("rfloor" "&#8971;")
- ("langle" "&#9001;")
- ("rangle" "&#9002;")
- ;; Misc
- ("loz" "&#9674;")
- ("spades" "&#9824;")
- ("clubs" "&#9827;")
- ("hearts" "&#9829;")
- ("diams" "&#9830;")
- ("euro" "&#8464;")
- ;; LaTeX
- ("dag" "dag")
- ("ddag" "ddag")
- ("circ" "o")
- ("top" "T")
- ("bottom" "&#8869;")
- ("lhd" "<")
- ("rhd" ">")
- ("parallel" "||")))))
-
-;*---------------------------------------------------------------------*/
-;* html-title-engine ... */
-;*---------------------------------------------------------------------*/
-(define html-title-engine
- (copy-engine 'html-title base-engine
- :filter (make-string-replace '((#\< "&lt;")
- (#\> "&gt;")
- (#\& "&amp;")
- (#\" "&quot;")))))
-
-;*---------------------------------------------------------------------*/
-;* 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 '((#\< "&lt;")
- (#\> "&gt;")
- (#\& "&amp;")
- (#\" "&quot;")
- (#\@ "&#x40;"))))))
-
-;*---------------------------------------------------------------------*/
-;* 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))