From e9509518623d016880392237a298d4561a3b6a0b Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Mon, 31 Oct 2005 16:03:18 +0000 Subject: Removed useless files, integrated packages. * src/guile/skribilo/packages: New directory and files. * bin: Removed. * skr: Removed (files moved to `src/guile/skribilo/packages'). * skribe: Removed. * doc/skr/env.skr (*courtes-mail*): New. * doc/user/user.skb: Removed postal addresses, added my name. * src/guile/skribilo/engine/lout.scm: Uncommented the slide-related markup writers. * src/guile/skribilo/evaluator.scm (%evaluate): Try weird things with source properties. * src/guile/skribilo/reader/skribe.scm: Comply with the new guile-reader API. * src/guile/skribilo/types.scm: Removed the special `initialize' method for ASTs which was supposed to set their location. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-7 --- src/guile/skribilo/engine/lout.scm | 174 ++++---- src/guile/skribilo/evaluator.scm | 12 +- src/guile/skribilo/packages/acmproc.scm | 155 +++++++ src/guile/skribilo/packages/french.scm | 21 + src/guile/skribilo/packages/jfp.scm | 319 +++++++++++++ src/guile/skribilo/packages/letter.scm | 148 ++++++ src/guile/skribilo/packages/lncs.scm | 149 +++++++ src/guile/skribilo/packages/scribe.scm | 231 ++++++++++ src/guile/skribilo/packages/sigplan.scm | 157 +++++++ src/guile/skribilo/packages/skribe.scm | 76 ++++ src/guile/skribilo/packages/slide.scm | 667 ++++++++++++++++++++++++++++ src/guile/skribilo/packages/web-article.scm | 232 ++++++++++ src/guile/skribilo/packages/web-book.scm | 107 +++++ src/guile/skribilo/reader/skribe.scm | 36 +- src/guile/skribilo/skribe/param.scm | 19 +- src/guile/skribilo/types.scm | 8 - 16 files changed, 2393 insertions(+), 118 deletions(-) create mode 100644 src/guile/skribilo/packages/acmproc.scm create mode 100644 src/guile/skribilo/packages/french.scm create mode 100644 src/guile/skribilo/packages/jfp.scm create mode 100644 src/guile/skribilo/packages/letter.scm create mode 100644 src/guile/skribilo/packages/lncs.scm create mode 100644 src/guile/skribilo/packages/scribe.scm create mode 100644 src/guile/skribilo/packages/sigplan.scm create mode 100644 src/guile/skribilo/packages/skribe.scm create mode 100644 src/guile/skribilo/packages/slide.scm create mode 100644 src/guile/skribilo/packages/web-article.scm create mode 100644 src/guile/skribilo/packages/web-book.scm (limited to 'src') diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index b675e8a..b466ac1 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -2876,93 +2876,93 @@ ;*---------------------------------------------------------------------*/ ;* Slides */ ;* */ -;* At some point, this should move to `slide.skr'. */ -;*---------------------------------------------------------------------*/ -; (skribe-load "slide.skr") - -; (markup-writer 'slide -; ;; FIXME: In `slide.skr', `:ident' is systematically generated. -; :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) - -; :validate (lambda (n e) -; (eq? (engine-custom e 'document-type) 'slides)) - -; :before (lambda (n e) -; (display "\n@Overhead\n") -; (display " @Title { ") -; (output (markup-option n :title) e) -; (display " }\n") -; (if (markup-ident n) -; (begin -; (display " @Tag { ") -; (display (lout-tagify (markup-ident n))) -; (display " }\n"))) -; (if (markup-option n :number) -; (begin -; (display " @BypassNumber { ") -; (output (markup-option n :number) e) -; (display " }\n"))) -; (display "@Begin\n") - -; ;; `doc' documents produce their PDF outline right after -; ;; `@Text @Begin'; other types of documents must produce it -; ;; as part of their first chapter. -; (lout-output-pdf-meta-info (ast-document n) e)) - -; :after "@End @Overhead\n") - -; (markup-writer 'slide-vspace -; :options '(:unit) -; :validate (lambda (n e) -; (and (pair? (markup-body n)) -; (number? (car (markup-body n))))) -; :action (lambda (n e) -; (printf "\n//~a~a # slide-vspace\n" -; (car (markup-body n)) -; (case (markup-option n :unit) -; ((cm) "c") -; ((point points pt) "p") -; ((inch inches) "i") -; (else -; (skribe-error 'lout -; "Unknown vspace unit" -; (markup-option n :unit))))))) - -; (markup-writer 'slide-pause -; ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. -; ;; << /Type /Action -; ;; << /S /Trans -; ;; entry in the trans dict -; ;; << /Type /Trans /S /Dissolve >> -; :action (lambda (n e) -; (let ((filter (make-string-replace lout-verbatim-encoding)) -; (pdfmark " -; [ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) -; (display (lout-embedded-postscript-code -; (filter pdfmark)))))) - -; ;; For movies, see -; ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . -; (markup-writer 'slide-embed -; :options '(:alt :geometry :rgeometry :geometry-opt :command) -; ;; FIXME: `pdfmark'. -; ;; << /Type /Action /S /Launch -; :action (lambda (n e) -; (let ((command (markup-option n :command)) -; (filter (make-string-replace lout-verbatim-encoding)) -; (pdfmark "[ /Rect [ 0 ysize xsize 0 ] -; /Name /Comment -; /Contents (This is an embedded application) -; /ANN pdfmark - -; [ /Type /Action -; /S /Launch -; /F (~a) -; /OBJ pdfmark")) -; (display (string-append -; "4c @Wide 3c @High " -; (lout-embedded-postscript-code -; (filter (format #f pdfmark command)))))))) +;* At some point, we might want to move this to `slide.scm'. */ +;*---------------------------------------------------------------------*/ + +(use-modules (skribilo packages slide)) + +(markup-writer 'slide + :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) + + :validate (lambda (n e) + (eq? (engine-custom e 'document-type) 'slides)) + + :before (lambda (n e) + (display "\n@Overhead\n") + (display " @Title { ") + (output (markup-option n :title) e) + (display " }\n") + (if (markup-ident n) + (begin + (display " @Tag { ") + (display (lout-tagify (markup-ident n))) + (display " }\n"))) + (if (markup-option n :number) + (begin + (display " @BypassNumber { ") + (output (markup-option n :number) e) + (display " }\n"))) + (display "@Begin\n") + + ;; `doc' documents produce their PDF outline right after + ;; `@Text @Begin'; other types of documents must produce it + ;; as part of their first chapter. + (lout-output-pdf-meta-info (ast-document n) e)) + + :after "@End @Overhead\n") + +(markup-writer 'slide-vspace + :options '(:unit) + :validate (lambda (n e) + (and (pair? (markup-body n)) + (number? (car (markup-body n))))) + :action (lambda (n e) + (printf "\n//~a~a # slide-vspace\n" + (car (markup-body n)) + (case (markup-option n :unit) + ((cm) "c") + ((point points pt) "p") + ((inch inches) "i") + (else + (skribe-error 'lout + "Unknown vspace unit" + (markup-option n :unit))))))) + +(markup-writer 'slide-pause + ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. + ;; << /Type /Action + ;; << /S /Trans + ;; entry in the trans dict + ;; << /Type /Trans /S /Dissolve >> + :action (lambda (n e) + (let ((filter (make-string-replace lout-verbatim-encoding)) + (pdfmark " +[ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) + (display (lout-embedded-postscript-code + (filter pdfmark)))))) + +For movies, see +http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . +(markup-writer 'slide-embed + :options '(:alt :geometry :rgeometry :geometry-opt :command) + ;; FIXME: `pdfmark'. + ;; << /Type /Action /S /Launch + :action (lambda (n e) + (let ((command (markup-option n :command)) + (filter (make-string-replace lout-verbatim-encoding)) + (pdfmark "[ /Rect [ 0 ysize xsize 0 ] + /Name /Comment + /Contents (This is an embedded application) + /ANN pdfmark + +[ /Type /Action + /S /Launch + /F (~a) + /OBJ pdfmark")) + (display (string-append + "4c @Wide 3c @High " + (lout-embedded-postscript-code + (filter (format #f pdfmark command)))))))) ;*---------------------------------------------------------------------*/ ;* Restore the base engine */ diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index 703186c..616144d 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -50,7 +50,17 @@ (define *skribe-load-options* '()) (define (%evaluate expr) - (eval expr (current-module))) + (let ((result (eval expr (current-module)))) + (if (or (ast? result) (markup? result)) + (let ((file (source-property expr 'filename)) + (line (source-property expr 'line)) + (column (source-property expr 'column))) + (format #t "~%~%*** source props for `~a': ~a~%~%" + result (source-properties expr)) + (slot-set! result 'loc + (make + :file file :line line :pos column)))) + result)) diff --git a/src/guile/skribilo/packages/acmproc.scm b/src/guile/skribilo/packages/acmproc.scm new file mode 100644 index 0000000..4accc7c --- /dev/null +++ b/src/guile/skribilo/packages/acmproc.scm @@ -0,0 +1,155 @@ +;*=====================================================================*/ +;* 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/src/guile/skribilo/packages/french.scm b/src/guile/skribilo/packages/french.scm new file mode 100644 index 0000000..3e454f5 --- /dev/null +++ b/src/guile/skribilo/packages/french.scm @@ -0,0 +1,21 @@ +;*=====================================================================*/ +;* 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 */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages french)) + +;*---------------------------------------------------------------------*/ +;* 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/src/guile/skribilo/packages/jfp.scm b/src/guile/skribilo/packages/jfp.scm new file mode 100644 index 0000000..e34a4fe --- /dev/null +++ b/src/guile/skribilo/packages/jfp.scm @@ -0,0 +1,319 @@ +;*=====================================================================*/ +;* 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. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages jfp)) + +;*---------------------------------------------------------------------*/ +;* 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/src/guile/skribilo/packages/letter.scm b/src/guile/skribilo/packages/letter.scm new file mode 100644 index 0000000..565a1eb --- /dev/null +++ b/src/guile/skribilo/packages/letter.scm @@ -0,0 +1,148 @@ +;*=====================================================================*/ +;* 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 */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages letter)) + +;*---------------------------------------------------------------------*/ +;* 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 "\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 "\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 "
") + (output n e) + (when hd + (display "") + (output hd e) + (set! hd #f)) + (display "
\n
\n\n")) + + diff --git a/src/guile/skribilo/packages/lncs.scm b/src/guile/skribilo/packages/lncs.scm new file mode 100644 index 0000000..4aadacc --- /dev/null +++ b/src/guile/skribilo/packages/lncs.scm @@ -0,0 +1,149 @@ +;*=====================================================================*/ +;* 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. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages lncs)) + +;*---------------------------------------------------------------------*/ +;* 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/src/guile/skribilo/packages/scribe.scm b/src/guile/skribilo/packages/scribe.scm new file mode 100644 index 0000000..c97f8e9 --- /dev/null +++ b/src/guile/skribilo/packages/scribe.scm @@ -0,0 +1,231 @@ +;*=====================================================================*/ +;* 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 */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages scribe)) + +;*---------------------------------------------------------------------*/ +;* 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/src/guile/skribilo/packages/sigplan.scm b/src/guile/skribilo/packages/sigplan.scm new file mode 100644 index 0000000..c4ea1e2 --- /dev/null +++ b/src/guile/skribilo/packages/sigplan.scm @@ -0,0 +1,157 @@ +;*=====================================================================*/ +;* 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. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages sigplan)) + +;*---------------------------------------------------------------------*/ +;* 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/src/guile/skribilo/packages/skribe.scm b/src/guile/skribilo/packages/skribe.scm new file mode 100644 index 0000000..86425ac --- /dev/null +++ b/src/guile/skribilo/packages/skribe.scm @@ -0,0 +1,76 @@ +;*=====================================================================*/ +;* 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/src/guile/skribilo/packages/slide.scm b/src/guile/skribilo/packages/slide.scm new file mode 100644 index 0000000..54ac21c --- /dev/null +++ b/src/guile/skribilo/packages/slide.scm @@ -0,0 +1,667 @@ +;*=====================================================================*/ +;* 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 */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages slide)) + +;*---------------------------------------------------------------------*/ +;* 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 (if (not ident) + (symbol->string (gensym 'slide)) + ident)) + (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 "
\n" + (html-width (slide-body-width e))) + (if (string? tbg) + (printf "
" tbg) + (display "")) + (if (string? tfg) + (printf "" tfg)) + (if title + (begin + (display "
") + (if (string? tfont) + (begin + (printf "" tfont) + (output title e) + (display "")) + (begin + (printf "
") + (output title e) + (display ""))) + (display "
\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "")) + (display "
\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 "" (markup-ident n)) + (display "
\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 "
") + ;; slide-vspace + (markup-writer 'slide-vspace he + :action (lambda (n e) (display "
")))) + +;*---------------------------------------------------------------------*/ +;* 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/src/guile/skribilo/packages/web-article.scm b/src/guile/skribilo/packages/web-article.scm new file mode 100644 index 0000000..f853231 --- /dev/null +++ b/src/guile/skribilo/packages/web-article.scm @@ -0,0 +1,232 @@ +;*=====================================================================*/ +;* 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 */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages web-article)) + +;*---------------------------------------------------------------------*/ +;* &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 "
\n" + (html-width (web-article-body-width e))) + (if (string? tbg) + (printf "
" tbg) + (display "")) + (if (string? tfg) + (printf "" tfg)) + (if title + (begin + (display "
") + (if (string? tfont) + (begin + (printf "" tfont) + (output title e) + (display "")) + (begin + (printf "

") + (output title e) + (display "

"))) + (display "
\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "")) + (display "
\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 "
\n" + (string-canonicalize id)) + (output title e) + (display "
\n") + ;; the authors + (printf "
\n" + (string-canonicalize id)) + (for-each (lambda (a) (output a e)) + (cond + ((is-markup? authors 'author) + (list authors)) + ((list? authors) + authors) + (else + '()))) + (display "
\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 "" + (string-canonicalize (markup-ident n))) + (output name e) + (display "\n")) + (when title + (printf "" + (string-canonicalize (markup-ident n))) + (output title e) + (display "\n")) + (when affiliation + (printf "" + (string-canonicalize (markup-ident n))) + (output affiliation e) + (display "\n")) + (when (pair? address) + (printf "" + (string-canonicalize (markup-ident n))) + (for-each (lambda (a) + (output a e) + (newline)) + address) + (display "\n")) + (when phone + (printf "" + (string-canonicalize (markup-ident n))) + (output phone e) + (display "\n")) + (when email + (printf "" + (string-canonicalize (markup-ident n))) + (output email e) + (display "\n")) + (when url + (printf "" + (string-canonicalize (markup-ident n))) + (output url e) + (display "\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 "
" + :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 "
" + :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 "
\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-document-title + :after "
\n") + ;; author + (markup-writer 'author he + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (printf "\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-author + :after "" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) (output n e sec)) + :after "\n") + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before (lambda (n e) + (printf "
" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) + (output n e ft)) + :after "
\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/src/guile/skribilo/packages/web-book.scm b/src/guile/skribilo/packages/web-book.scm new file mode 100644 index 0000000..f907c8b --- /dev/null +++ b/src/guile/skribilo/packages/web-book.scm @@ -0,0 +1,107 @@ +;*=====================================================================*/ +;* 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/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm index 673a166..78f1814 100644 --- a/src/guile/skribilo/reader/skribe.scm +++ b/src/guile/skribilo/reader/skribe.scm @@ -22,7 +22,7 @@ :use-module (skribilo reader) :use-module (ice-9 optargs) - ;; the Scheme reader composition framework + ;; the Scheme reader composition framework :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:)) :export (reader-specification @@ -55,18 +55,28 @@ the Skribe syntax." (map r:standard-token-reader '(character srfi-4 number+radix - boolean)))))) - (r:make-reader (cons (r:make-token-reader #\# sharp-reader) - (map r:standard-token-reader - `(whitespace - sexp string number - symbol-lower-case - symbol-upper-case - symbol-misc-chars - quote-quasiquote-unquote - semicolon-comment - keyword ;; keywords à la `:key' - skribe-exp)))))) + boolean))) + #f ;; use default fault handler + 'reader/record-positions)) + (colon-keywords ;; keywords à la `:key' fashion + (r:make-token-reader #\: + (r:token-reader-procedure + (r:standard-token-reader 'keyword))))) + + (r:make-reader (cons* (r:make-token-reader #\# sharp-reader) + colon-keywords + (map r:standard-token-reader + `(whitespace + sexp string number + symbol-lower-case + symbol-upper-case + symbol-misc-chars + quote-quasiquote-unquote + semicolon-comment + skribe-exp))) + #f ;; use the default fault handler + 'reader/record-positions + ))) ;; We actually cache an instance here. (define *skribe-reader* (%make-skribe-reader)) diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm index 8daca62..6aebd0a 100644 --- a/src/guile/skribilo/skribe/param.scm +++ b/src/guile/skribilo/skribe/param.scm @@ -44,15 +44,16 @@ ;* *skribe-auto-mode-alist* ... */ ;*---------------------------------------------------------------------*/ (define *skribe-auto-mode-alist* - '(("html" . html) - ("sui" . sui) - ("tex" . latex) - ("ctex" . context) - ("xml" . xml) - ("info" . info) - ("txt" . ascii) - ("mgp" . mgp) - ("man" . man))) + ;; Note: In Skribilo, this list is completely useless. + '(("html" . html) + ("sui" . sui) + ("tex" . latex) + ("ctex" . context) + ("xml" . xml) + ("info" . info) + ("txt" . ascii) + ("mgp" . mgp) + ("man" . man))) ;*---------------------------------------------------------------------*/ ;* *skribe-auto-load-alist* ... */ diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm index 4b3729c..c6188b6 100644 --- a/src/guile/skribilo/types.scm +++ b/src/guile/skribilo/types.scm @@ -66,14 +66,6 @@ (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified) (loc :init-value #f)) -(define-method (initialize (ast ) . args) - (next-method) - (let ((file (port-filename (current-input-port))) - (line (port-line (current-input-port))) - (column (port-column (current-input-port)))) - (slot-set! ast 'loc - (make - :file file :line line :pos (* line column))))) (define (ast? obj) (is-a? obj )) (define (ast-loc obj) (slot-ref obj 'loc)) -- cgit v1.2.3