From 02d1bf3d462a8356ec62a1c3aa07cb72cd58ea2b Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 17 Feb 2006 17:24:51 +0000 Subject: `slide' and `eq': moved engine-specific code in separate modules. * src/guile/skribilo/package/slide.scm: Moved engine-specific code to `slide/ENGINE.scm'. * src/guile/skribilo/package/eq.scm: Likewise. * configure.ac: Produce the new Makefiles. * src/guile/skribilo/engine/lout.scm: Export more stuff. Moved the slide-related things out of here. * src/guile/skribilo/utils/compat.scm (skribe-load): Removed `call/cc' (not needed). git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-51 --- configure.ac | 2 + src/guile/skribilo/engine/lout.scm | 105 +----- src/guile/skribilo/package/Makefile.am | 1 + src/guile/skribilo/package/eq.scm | 152 +-------- src/guile/skribilo/package/eq/Makefile.am | 4 + src/guile/skribilo/package/eq/lout.scm | 184 ++++++++++ src/guile/skribilo/package/slide.scm | 494 +++------------------------ src/guile/skribilo/package/slide/Makefile.am | 4 + src/guile/skribilo/package/slide/html.scm | 106 ++++++ src/guile/skribilo/package/slide/latex.scm | 385 +++++++++++++++++++++ src/guile/skribilo/package/slide/lout.scm | 131 +++++++ src/guile/skribilo/utils/compat.scm | 46 ++- 12 files changed, 897 insertions(+), 717 deletions(-) create mode 100644 src/guile/skribilo/package/eq/Makefile.am create mode 100644 src/guile/skribilo/package/eq/lout.scm create mode 100644 src/guile/skribilo/package/slide/Makefile.am create mode 100644 src/guile/skribilo/package/slide/html.scm create mode 100644 src/guile/skribilo/package/slide/latex.scm create mode 100644 src/guile/skribilo/package/slide/lout.scm diff --git a/configure.ac b/configure.ac index 17f914d..90ae155 100644 --- a/configure.ac +++ b/configure.ac @@ -35,6 +35,8 @@ AC_OUTPUT([Makefile src/guile/skribilo/engine/Makefile src/guile/skribilo/reader/Makefile src/guile/skribilo/package/Makefile + src/guile/skribilo/package/slide/Makefile + src/guile/skribilo/package/eq/Makefile src/guile/skribilo/skribe/Makefile src/guile/skribilo/coloring/Makefile doc/Makefile diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index de6fb3e..17eb237 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -28,10 +28,11 @@ :autoload (ice-9 rdelim) (read-line)) + ;*---------------------------------------------------------------------*/ ;* lout-verbatim-encoding ... */ ;*---------------------------------------------------------------------*/ -(define lout-verbatim-encoding +(define-public lout-verbatim-encoding '((#\/ "\"/\"") (#\\ "\"\\\\\"") (#\| "\"|\"") @@ -48,7 +49,7 @@ ;*---------------------------------------------------------------------*/ ;* lout-encoding ... */ ;*---------------------------------------------------------------------*/ -(define lout-encoding +(define-public lout-encoding `(,@lout-verbatim-encoding (#\ç "{ @Char ccedilla }") (#\Ç "{ @Char Ccdeilla }") @@ -349,7 +350,7 @@ (current-error-port)))) #t)) -(define (lout-tagify ident) +(define-public (lout-tagify ident) ;; Return an "clean" identifier (a string) based on `ident' (a string), ;; suitable for Lout as an `@Tag' value. (let ((tag-encoding '((#\, "-") @@ -776,7 +777,7 @@ `(,node ,engine ,@children))))) nodes)))) -(define (lout-embedded-postscript-code postscript) +(define-public (lout-embedded-postscript-code postscript) ;; Return a string embedding PostScript code `postscript' into Lout code. (string-append "\n" "{ @BackEnd @Case {\n" @@ -785,7 +786,7 @@ " }\n" "} } @Graphic { }\n")) -(define (lout-pdf-docinfo doc engine) +(define-public (lout-pdf-docinfo doc engine) ;; Produce PostScript code that will produce PDF document information once ;; converted to PDF. (let* ((filter-string (make-string-replace `(,@lout-verbatim-encoding @@ -845,7 +846,7 @@ extra-fields))) "\"/\"DOCINFO pdfmark\n"))) -(define (lout-output-pdf-meta-info doc engine) +(define-public (lout-output-pdf-meta-info doc engine) ;; Produce PDF bookmarks (aka. "outline") for document `doc', as well as ;; document meta-information (or "docinfo"). This function makes sure that ;; both are only produced once, and only if the relevant customs ask for @@ -2872,98 +2873,6 @@ (image :file output alt)))))) - -;*---------------------------------------------------------------------*/ -;* Slides */ -;* */ -;* At some point, we might want to move this to `slide.scm'. */ -;*---------------------------------------------------------------------*/ - -(use-modules (skribilo package 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/package/Makefile.am b/src/guile/skribilo/package/Makefile.am index 781b1aa..6cb30b9 100644 --- a/src/guile/skribilo/package/Makefile.am +++ b/src/guile/skribilo/package/Makefile.am @@ -4,3 +4,4 @@ dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \ slide.scm web-article.scm web-book.scm \ eq.scm +SUBDIRS = slide eq diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index 9be8f61..410f04f 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -44,6 +44,7 @@ (fluid-set! current-reader %skribilo-module-reader) + ;;; ;;; Utilities. @@ -138,147 +139,6 @@ (body (the-body opts)))) - -;;; -;;; Lout implementation -;;; - -(let ((lout (find-engine 'lout))) - (if (not lout) - (skribe-error 'eq "Lout engine not found" lout) - (let ((includes (engine-custom lout 'includes))) - ;; Append the `eq' include file - (engine-custom-set! lout 'includes - (string-append includes "\n" - "@SysInclude { eq }\n"))))) - -;; FIXME: Reimplement the `symbol' writer so that `@Sym' is not used within -;; equations (e.g. output `alpha' instead of `{ @Sym alpha }'). - -(markup-writer 'eq (find-engine 'lout) - :before "\n@Eq { " - :action (lambda (node engine) - (let ((eq (markup-body node))) - ;(fprint (current-error-port) "eq=" eq) - (output eq engine))) - :after " }\n") - - -;; -;; `+' and `-' have lower precedence than `*', `/', `=', etc., so their -;; operands do not need to be enclosed in braces. -;; - -(markup-writer 'eq:+ (find-engine 'lout) - :action (lambda (node engine) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (begin - ;; no braces - (output (car operands) engine) - (if (pair? (cdr operands)) - (display " + ")) - (loop (cdr operands))))))) - -(markup-writer 'eq:- (find-engine 'lout) - :action (lambda (node engine) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (begin - ;; no braces - (output (car operands) engine) - (if (pair? (cdr operands)) - (display " - ")) - (loop (cdr operands))))))) - -(define-macro (simple-lout-markup-writer sym . lout-name) - `(markup-writer ',(symbol-append 'eq: sym) - (find-engine 'lout) - :action (lambda (node engine) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (begin - (display " { ") - (output (car operands) engine) - (display " }") - (if (pair? (cdr operands)) - (display ,(string-append " " - (if (null? lout-name) - (symbol->string sym) - (car lout-name)) - " "))) - (loop (cdr operands)))))))) - -(simple-lout-markup-writer * "times") -(simple-lout-markup-writer / "over") -(simple-lout-markup-writer =) -(simple-lout-markup-writer <) -(simple-lout-markup-writer >) -(simple-lout-markup-writer <=) -(simple-lout-markup-writer >=) - -(markup-writer 'eq:expt (find-engine 'lout) - :action (lambda (node engine) - (let ((body (markup-body node))) - (if (= (length body) 2) - (let ((base (car body)) - (expt (cadr body))) - (display " { { ") - (if (markup? base) (display "(")) - (output base engine) - (if (markup? base) (display ")")) - (display " } sup { ") - (output expt engine) - (display " } } ")) - (skribe-error 'eq:expt "wrong number of arguments" - body))))) - - -;;; -;;; Sums, products, integrals, etc. -;;; - -(define-macro (range-lout-markup-writer sym lout-name) - `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) - :action (lambda (node engine) - (let ((from (markup-option node :from)) - (to (markup-option node :to)) - (body (markup-body node))) - (display ,(string-append " { big " lout-name - " from { ")) - (output from engine) - (display " } to { ") - (output to engine) - (display " } { ") - (output body engine) - (display " } } "))))) - -(range-lout-markup-writer sum "sum") -(range-lout-markup-writer product "prod") - -(markup-writer 'eq:script (find-engine 'lout) - :action (lambda (node engine) - (let ((body (markup-body node)) - (sup (markup-option node :sup)) - (sub (markup-option node :sub))) - (display " { { ") - (output body engine) - (display " } ") - (if sup - (begin - (display (if sub " supp { " " sup { ")) - (output sup engine) - (display " } "))) - (if sub - (begin - (display " on { ") - (output sub engine) - (display " } "))) - (display " } ")))) - ;;; ;;; Text-only implementation. @@ -301,6 +161,16 @@ (display " / ")) (loop (cdr operands))))))) + +;;; +;;; Initialization. +;;; + +(when-engine-is-loaded 'lout + (lambda () + (resolve-module '(skribilo package eq lout)))) + + ;;; arch-tag: 58764650-2684-47a6-8cc7-6288f2b474da ;;; eq.scm ends here diff --git a/src/guile/skribilo/package/eq/Makefile.am b/src/guile/skribilo/package/eq/Makefile.am new file mode 100644 index 0000000..c7b4f93 --- /dev/null +++ b/src/guile/skribilo/package/eq/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package/eq +dist_guilemodule_DATA = lout.scm + +## arch-tag: 3e816c9a-7989-4baa-b38b-a095a5428ba1 diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm new file mode 100644 index 0000000..30a6d39 --- /dev/null +++ b/src/guile/skribilo/package/eq/lout.scm @@ -0,0 +1,184 @@ +;;; lout.scm -- Lout implementation of the `eq' package. +;;; +;;; Copyright 2005, 2006 Ludovic Courtès +;;; +;;; +;;; 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. + +(define-module (skribilo package eq lout) + :use-module (skribilo package eq) + :use-module (skribilo ast) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo skribe utils) ;; `the-options', etc. + :use-module (ice-9 optargs)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Initialization. +;;; + +(let ((lout (find-engine 'lout))) + (if (not lout) + (skribe-error 'eq "Lout engine not found" lout) + (let ((includes (engine-custom lout 'includes))) + ;; Append the `eq' include file + (engine-custom-set! lout 'includes + (string-append includes "\n" + "@SysInclude { eq }\n"))))) + + +;;; +;;; Simple markup writers. +;;; + + +;; FIXME: Reimplement the `symbol' writer so that `@Sym' is not used within +;; equations (e.g. output `alpha' instead of `{ @Sym alpha }'). + +(markup-writer 'eq (find-engine 'lout) + :before "\n@Eq { " + :action (lambda (node engine) + (let ((eq (markup-body node))) + ;(fprint (current-error-port) "eq=" eq) + (output eq engine))) + :after " }\n") + + +;; +;; `+' and `-' have lower precedence than `*', `/', `=', etc., so their +;; operands do not need to be enclosed in braces. +;; + +(markup-writer 'eq:+ (find-engine 'lout) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (begin + ;; no braces + (output (car operands) engine) + (if (pair? (cdr operands)) + (display " + ")) + (loop (cdr operands))))))) + +(markup-writer 'eq:- (find-engine 'lout) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (begin + ;; no braces + (output (car operands) engine) + (if (pair? (cdr operands)) + (display " - ")) + (loop (cdr operands))))))) + +(define-macro (simple-lout-markup-writer sym . lout-name) + `(markup-writer ',(symbol-append 'eq: sym) + (find-engine 'lout) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (begin + (display " { ") + (output (car operands) engine) + (display " }") + (if (pair? (cdr operands)) + (display ,(string-append " " + (if (null? lout-name) + (symbol->string sym) + (car lout-name)) + " "))) + (loop (cdr operands)))))))) + +(simple-lout-markup-writer * "times") +(simple-lout-markup-writer / "over") +(simple-lout-markup-writer =) +(simple-lout-markup-writer <) +(simple-lout-markup-writer >) +(simple-lout-markup-writer <=) +(simple-lout-markup-writer >=) + +(markup-writer 'eq:expt (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (let ((base (car body)) + (expt (cadr body))) + (display " { { ") + (if (markup? base) (display "(")) + (output base engine) + (if (markup? base) (display ")")) + (display " } sup { ") + (output expt engine) + (display " } } ")) + (skribe-error 'eq:expt "wrong number of arguments" + body))))) + + + +;;; +;;; Sums, products, integrals, etc. +;;; + +(define-macro (range-lout-markup-writer sym lout-name) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let ((from (markup-option node :from)) + (to (markup-option node :to)) + (body (markup-body node))) + (display ,(string-append " { big " lout-name + " from { ")) + (output from engine) + (display " } to { ") + (output to engine) + (display " } { ") + (output body engine) + (display " } } "))))) + +(range-lout-markup-writer sum "sum") +(range-lout-markup-writer product "prod") + +(markup-writer 'eq:script (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node)) + (sup (markup-option node :sup)) + (sub (markup-option node :sub))) + (display " { { ") + (output body engine) + (display " } ") + (if sup + (begin + (display (if sub " supp { " " sup { ")) + (output sup engine) + (display " } "))) + (if sub + (begin + (display " on { ") + (output sub engine) + (display " } "))) + (display " } ")))) + + +;;; arch-tag: 2a1410e5-977e-4600-b781-3d57f4409b35 diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm index 5b39239..8968d00 100644 --- a/src/guile/skribilo/package/slide.scm +++ b/src/guile/skribilo/package/slide.scm @@ -1,82 +1,60 @@ -;*=====================================================================*/ -;* 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.scm -- Overhead transparencies. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 Ludovic Courtès +;;; +;;; +;;; 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. + (define-skribe-module (skribilo package slide) - :autoload (skribilo engine html) (html-width html-title-authors)) + :autoload (skribilo engine html) (html-width html-title-authors) + :autoload (skribilo package slide html) (%slide-html-initialize!) + :autoload (skribilo package slide lout) (%slide-lout-initialize!) + :autoload (skribilo package slide latex) (%slide-latex-initialize!)) ;*---------------------------------------------------------------------*/ ;* 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") +(define-public &slide-load-options (skribe-load-options)) -;*---------------------------------------------------------------------*/ -;* &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))))) +(format (current-error-port) "Slides initializing...~%") + +;; Register specific implementations for lazy loading. +(when-engine-is-loaded 'latex + (lambda () + (%slide-latex-initialize!))) +(when-engine-is-loaded 'html + (lambda () + (%slide-html-initialize!))) +(when-engine-is-loaded 'lout + (lambda () + (%slide-lout-initialize!))) + ;*---------------------------------------------------------------------*/ ;* slide ... */ @@ -89,7 +67,6 @@ (vspace #f) (vfill #f) (transition #f) (bg #f) (image #f)) - (%slide-initialize!) (let ((s (new container (markup 'slide) (ident (if (not ident) @@ -288,403 +265,12 @@ :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) +(define-public (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 #f "~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) - -;;; FIXME: We shouldn't load `latex.scm' from here. Instead, we should -;;; register a hook on its load. -(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 #f "~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/package/slide/Makefile.am b/src/guile/skribilo/package/slide/Makefile.am new file mode 100644 index 0000000..e5fb908 --- /dev/null +++ b/src/guile/skribilo/package/slide/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package/slide +dist_guilemodule_DATA = latex.scm html.scm lout.scm + +## arch-tag: 56b5fa5c-bb6a-4692-b929-74bdd032431c diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm new file mode 100644 index 0000000..5398fbf --- /dev/null +++ b/src/guile/skribilo/package/slide/html.scm @@ -0,0 +1,106 @@ +;;; html.scm -- HTML implementation of the `slide' package. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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. + +(define-skribe-module (skribilo package slide html) + :use-module (skribilo package slide)) + + +(define-public (%slide-html-initialize!) + (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 #f "~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 "
"))))) + +;*---------------------------------------------------------------------*/ +;* 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"))) + + +;;; arch-tag: 8be0cdf2-b755-4baa-baf6-739cdd00e193 diff --git a/src/guile/skribilo/package/slide/latex.scm b/src/guile/skribilo/package/slide/latex.scm new file mode 100644 index 0000000..15f4535 --- /dev/null +++ b/src/guile/skribilo/package/slide/latex.scm @@ -0,0 +1,385 @@ +;;; latex.scm -- LaTeX implementation of the `slide' package. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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. + +(define-skribe-module (skribilo package slide latex) + :use-module (skribilo package slide)) + + +(define-public %slide-latex-mode 'seminar) + +(define-public (%slide-latex-initialize!) + (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-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") + +;*---------------------------------------------------------------------*/ +;* 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) + +;;; FIXME: We shouldn't load `latex.scm' from here. Instead, we should +;;; register a hook on its load. +(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 #f "~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))))) + + +;;; arch-tag: b99e2c65-55f7-462c-8482-f47c7e223538 diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm new file mode 100644 index 0000000..f816469 --- /dev/null +++ b/src/guile/skribilo/package/slide/lout.scm @@ -0,0 +1,131 @@ +;;; lout.scm -- Lout implementation of the `slide' package. +;;; +;;; Copyright 2005, 2006 Ludovic Courtès +;;; +;;; +;;; 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. + +(define-skribe-module (skribilo package slide lout) + :use-module (skribilo utils syntax) + + ;; FIXME: For some reason, changing the following `autoload' in + ;; `use-modules' doesn't work. + + :autoload (skribilo engine lout) (lout-tagify lout-output-pdf-meta-info) + ) + + +(fluid-set! current-reader %skribilo-module-reader) + +;;; TODO: +;;; +;;; Make some more PS/PDF trickery. + +(format (current-error-port) "slide/lout.scm~%") + +(define-public (%slide-lout-initialize!) + (format (current-error-port) "Lout slides initializing...~%") + + (let ((le (find-engine 'lout))) + + ;; Automatically switch to the `slides' document type. + (engine-custom-set! le 'document-type 'slides) + + (markup-writer 'slide le + :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 le + :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 le + ;; 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 le + :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)))))))))) + + +;;; arch-tag: 0c717553-5cbb-46ed-937a-f844b6aeb145 diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm index 3fce068..9ed9f3e 100644 --- a/src/guile/skribilo/utils/compat.scm +++ b/src/guile/skribilo/utils/compat.scm @@ -136,30 +136,28 @@ ("acmproc.skr" . (skribilo package acmproc)))) (define*-public (skribe-load file :rest args) - (call/cc - (lambda (return) - (guard (c ((file-search-error? c) - ;; Regular file loading failed. Try built-ins. - (let ((mod-name (assoc-ref %skribe-known-files file))) - (if mod-name - (begin - (if (> (*verbose*) 1) - (format (current-error-port) - " skribe-load: `~a' -> `~a'~%" - file mod-name)) - (let ((mod (false-if-exception - (resolve-module mod-name)))) - (if (not mod) - (raise c) - (begin - (set-module-uses! - (current-module) - (cons mod (module-uses (current-module)))) - (return #t))))) - (raise c))))) - - ;; Try a regular `load-document'. - (apply load-document file args))))) + (guard (c ((file-search-error? c) + ;; Regular file loading failed. Try built-ins. + (let ((mod-name (assoc-ref %skribe-known-files file))) + (if mod-name + (begin + (if (> (*verbose*) 1) + (format (current-error-port) + " skribe-load: `~a' -> `~a'~%" + file mod-name)) + (let ((mod (false-if-exception + (resolve-module mod-name)))) + (if (not mod) + (raise c) + (begin + (set-module-uses! + (current-module) + (cons mod (module-uses (current-module)))) + #t)))) + (raise c))))) + + ;; Try a regular `load-document'. + (apply load-document file args))) (define-public skribe-include include-document) -- cgit v1.2.3