diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/guile/skribilo/color.scm | 64 | ||||
| -rw-r--r-- | src/guile/skribilo/engine.scm | 54 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/html.scm | 2 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/lout.scm | 390 | ||||
| -rw-r--r-- | src/guile/skribilo/module.scm | 6 | ||||
| -rw-r--r-- | src/guile/skribilo/package/Makefile.am | 5 | ||||
| -rw-r--r-- | src/guile/skribilo/package/eq.scm | 243 | ||||
| -rw-r--r-- | src/guile/skribilo/package/eq/Makefile.am | 4 | ||||
| -rw-r--r-- | src/guile/skribilo/package/eq/lout.scm | 206 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide.scm | 494 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide/Makefile.am | 4 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide/html.scm | 106 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide/latex.scm | 385 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide/lout.scm | 131 | ||||
| -rw-r--r-- | src/guile/skribilo/reader/skribe.scm | 21 | ||||
| -rw-r--r-- | src/guile/skribilo/runtime.scm | 17 | ||||
| -rw-r--r-- | src/guile/skribilo/utils/Makefile.am | 2 | ||||
| -rw-r--r-- | src/guile/skribilo/utils/compat.scm | 61 | ||||
| -rw-r--r-- | src/guile/skribilo/utils/files.scm | 55 | ||||
| -rwxr-xr-x | src/skribilo.in | 19 |
20 files changed, 1467 insertions, 802 deletions
diff --git a/src/guile/skribilo/color.scm b/src/guile/skribilo/color.scm index 1e762e6..d2ba1d4 100644 --- a/src/guile/skribilo/color.scm +++ b/src/guile/skribilo/color.scm @@ -1,32 +1,33 @@ -;;;; -;;;; color.scm -- Skribe Color Management -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 25-Oct-2003 00:10 (eg) -;;;; Last file update: 12-Feb-2004 18:24 (eg) -;;;; +;;; color.scm -- Color management. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + (define-module (skribilo color) - :export (skribe-color->rgb skribe-get-used-colors skribe-use-color!)) + :autoload (srfi srfi-60) (bitwise-and arithmetic-shift) + :export (skribe-color->rgb skribe-get-used-colors skribe-use-color!)) + +;; FIXME: This module should be generalized and the `skribe-' procedures +;; moved to `compat.scm'. +;; FIXME: Use a fluid? Or remove it? (define *used-colors* '()) (define *skribe-rgb-alist* '( @@ -571,7 +572,7 @@ ("darkmagenta" . "139 0 139") ("darkred" . "139 0 0") ("lightgreen" . "144 238 144"))) - + (define (%convert-color str) (let ((col (assoc str *skribe-rgb-alist*))) @@ -590,7 +591,7 @@ (values (string->number (substring str 1 5) 16) (string->number (substring str 5 9) 16) (string->number (substring str 9 13) 16))) - (else + (else (values 0 0 0))))) ;;; @@ -600,9 +601,9 @@ (cond ((string? spec) (%convert-color spec)) ((integer? spec) - (values (bit-and #xff (bit-shift spec -16)) - (bit-and #xff (bit-shift spec -8)) - (bit-and #xff spec))) + (values (bitwise-and #xff (arithmetic-shift spec -16)) + (bitwise-and #xff (arithmetic-shift spec -8)) + (bitwise-and #xff spec))) (else (values 0 0 0)))) @@ -618,4 +619,3 @@ (define (skribe-use-color! color) (set! *used-colors* (cons color *used-colors*)) color) - diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm index d747ea0..5800486 100644 --- a/src/guile/skribilo/engine.scm +++ b/src/guile/skribilo/engine.scm @@ -41,7 +41,9 @@ engine-custom engine-custom-set! engine-format? engine-add-writer! processor-get-engine - push-default-engine pop-default-engine)) + push-default-engine pop-default-engine + + engine-loaded? when-engine-is-loaded)) (fluid-set! current-reader %skribilo-module-reader) @@ -180,10 +182,50 @@ new)) + ;;; -;;; FIND-ENGINE +;;; Engine loading. ;;; +;; Each engine is to be stored in its own module with the `(skribilo engine)' +;; hierarchy. The `engine-id->module-name' procedure returns this module +;; name based on the engine name. + +(define (engine-id->module-name id) + `(skribilo engine ,id)) + +(define (engine-loaded? id) + "Check whether engine @var{id} is already loaded." + ;; Trick taken from `resolve-module' in `boot-9.scm'. + (nested-ref the-root-module + `(%app modules ,@(engine-id->module-name id)))) + +;; A mapping of engine names to hooks. +(define %engine-load-hook (make-hash-table)) + +(define (consume-load-hook! id) + (with-debug 5 'consume-load-hook! + (let ((hook (hashq-ref %engine-load-hook id))) + (if hook + (begin + (debug-item "running hook " hook " for engine " id) + (hashq-remove! %engine-load-hook id) + (run-hook hook)))))) + +(define (when-engine-is-loaded id thunk) + "Run @var{thunk} only when engine with identifier @var{id} is loaded." + (if (engine-loaded? id) + (begin + ;; Maybe the engine had already been loaded via `use-modules'. + (consume-load-hook! id) + (thunk)) + (let ((hook (or (hashq-ref %engine-load-hook id) + (let ((hook (make-hook))) + (hashq-set! %engine-load-hook id hook) + hook)))) + (add-hook! hook thunk)))) + + (define* (lookup-engine id :key (version 'unspecified)) "Look for an engine named @var{name} (a symbol) in the @code{(skribilo engine)} module hierarchy. If no such engine was found, an error is raised, @@ -192,15 +234,19 @@ otherwise the requested engine is returned." (debug-item "id=" id " version=" version) (let* ((engine (symbol-append id '-engine)) - (m (resolve-module `(skribilo engine ,id)))) + (m (resolve-module (engine-id->module-name id)))) (if (module-bound? m engine) - (module-ref m engine) + (let ((e (module-ref m engine))) + (if e (consume-load-hook! id)) + e) (error "no such engine" id))))) (define* (find-engine id :key (version 'unspecified)) (false-if-exception (apply lookup-engine (list id version)))) + + ;;; ;;; Engine methods. diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm index 1ad86e9..4ba058a 100644 --- a/src/guile/skribilo/engine/html.scm +++ b/src/guile/skribilo/engine/html.scm @@ -554,7 +554,7 @@ ;*---------------------------------------------------------------------*/ ;* html-markup-class ... */ ;*---------------------------------------------------------------------*/ -(define (html-markup-class m) +(define-public (html-markup-class m) (lambda (n e) (printf "<~a" m) (html-class n) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index c2339ca..c49211f 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -1,6 +1,6 @@ ;;; lout.scm -- A Lout engine. ;;; -;;; Copyright 2004, 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2004, 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -24,13 +24,15 @@ (define-skribe-module (skribilo engine lout) + :autoload (ice-9 popen) (open-output-pipe) :autoload (ice-9 rdelim) (read-line)) + ;*---------------------------------------------------------------------*/ ;* lout-verbatim-encoding ... */ ;*---------------------------------------------------------------------*/ -(define lout-verbatim-encoding +(define-public lout-verbatim-encoding '((#\/ "\"/\"") (#\\ "\"\\\\\"") (#\| "\"|\"") @@ -47,7 +49,7 @@ ;*---------------------------------------------------------------------*/ ;* lout-encoding ... */ ;*---------------------------------------------------------------------*/ -(define lout-encoding +(define-public lout-encoding `(,@lout-verbatim-encoding (#\ç "{ @Char ccedilla }") (#\Ç "{ @Char Ccdeilla }") @@ -111,7 +113,7 @@ ;*---------------------------------------------------------------------*/ ;* lout-symbol-table ... */ ;*---------------------------------------------------------------------*/ -(define (lout-symbol-table math) +(define (lout-symbol-table sym math) `(("iexcl" "{ @Char exclamdown }") ("cent" "{ @Char cent }") ("pound" "{ @Char sterling }") @@ -155,7 +157,7 @@ ("Ocircumflex" "{ @Char Ocircumflex }") ("Otilde" "{ @Char Otilde }") ("Ouml" "{ @Char Odieresis }") - ("times" "{ @Sym multiply }") + ("times" ,(sym "multiply")) ("Oslash" "{ @Char oslash }") ("Ugrave" "{ @Char Ugrave }") ("Uacute" "{ @Char Uacute }") @@ -195,100 +197,100 @@ ("yacute" "{ @Char yacute }") ("ymul" "{ @Char ydieresis }") ;; FIXME: `yUMl' ;; Greek - ("Alpha" "{ @Sym Alpha }") - ("Beta" "{ @Sym Beta }") - ("Gamma" "{ @Sym Gamma }") - ("Delta" "{ @Sym Delta }") - ("Epsilon" "{ @Sym Epsilon }") - ("Zeta" "{ @Sym Zeta }") - ("Eta" "{ @Sym Eta }") - ("Theta" "{ @Sym Theta }") - ("Iota" "{ @Sym Iota }") - ("Kappa" "{ @Sym Kappa }") - ("Lambda" "{ @Sym Lambda }") - ("Mu" "{ @Sym Mu }") - ("Nu" "{ @Sym Nu }") - ("Xi" "{ @Sym Xi }") - ("Omicron" "{ @Sym Omicron }") - ("Pi" "{ @Sym Pi }") - ("Rho" "{ @Sym Rho }") - ("Sigma" "{ @Sym Sigma }") - ("Tau" "{ @Sym Tau }") - ("Upsilon" "{ @Sym Upsilon }") - ("Phi" "{ @Sym Phi }") - ("Chi" "{ @Sym Chi }") - ("Psi" "{ @Sym Psi }") - ("Omega" "{ @Sym Omega }") - ("alpha" "{ @Sym alpha }") - ("beta" "{ @Sym beta }") - ("gamma" "{ @Sym gamma }") - ("delta" "{ @Sym delta }") - ("epsilon" "{ @Sym epsilon }") - ("zeta" "{ @Sym zeta }") - ("eta" "{ @Sym eta }") - ("theta" "{ @Sym theta }") - ("iota" "{ @Sym iota }") - ("kappa" "{ @Sym kappa }") - ("lambda" "{ @Sym lambda }") - ("mu" "{ @Sym mu }") - ("nu" "{ @Sym nu }") - ("xi" "{ @Sym xi }") - ("omicron" "{ @Sym omicron }") - ("pi" "{ @Sym pi }") - ("rho" "{ @Sym rho }") - ("sigmaf" "{ @Sym sigmaf }") ;; FIXME! - ("sigma" "{ @Sym sigma }") - ("tau" "{ @Sym tau }") - ("upsilon" "{ @Sym upsilon }") - ("phi" "{ @Sym phi }") - ("chi" "{ @Sym chi }") - ("psi" "{ @Sym psi }") - ("omega" "{ @Sym omega }") - ("thetasym" "{ @Sym thetasym }") - ("piv" "{ @Sym piv }") ;; FIXME! + ("Alpha" ,(sym "Alpha")) + ("Beta" ,(sym "Beta")) + ("Gamma" ,(sym "Gamma")) + ("Delta" ,(sym "Delta")) + ("Epsilon" ,(sym "Epsilon")) + ("Zeta" ,(sym "Zeta")) + ("Eta" ,(sym "Eta")) + ("Theta" ,(sym "Theta")) + ("Iota" ,(sym "Iota")) + ("Kappa" ,(sym "Kappa")) + ("Lambda" ,(sym "Lambda")) + ("Mu" ,(sym "Mu")) + ("Nu" ,(sym "Nu")) + ("Xi" ,(sym "Xi")) + ("Omicron" ,(sym "Omicron")) + ("Pi" ,(sym "Pi")) + ("Rho" ,(sym "Rho")) + ("Sigma" ,(sym "Sigma")) + ("Tau" ,(sym "Tau")) + ("Upsilon" ,(sym "Upsilon")) + ("Phi" ,(sym "Phi")) + ("Chi" ,(sym "Chi")) + ("Psi" ,(sym "Psi")) + ("Omega" ,(sym "Omega")) + ("alpha" ,(sym "alpha")) + ("beta" ,(sym "beta")) + ("gamma" ,(sym "gamma")) + ("delta" ,(sym "delta")) + ("epsilon" ,(sym "epsilon")) + ("zeta" ,(sym "zeta")) + ("eta" ,(sym "eta")) + ("theta" ,(sym "theta")) + ("iota" ,(sym "iota")) + ("kappa" ,(sym "kappa")) + ("lambda" ,(sym "lambda")) + ("mu" ,(sym "mu")) + ("nu" ,(sym "nu")) + ("xi" ,(sym "xi")) + ("omicron" ,(sym "omicron")) + ("pi" ,(sym "pi")) + ("rho" ,(sym "rho")) + ("sigmaf" ,(sym "sigmaf")) ;; FIXME! + ("sigma" ,(sym "sigma")) + ("tau" ,(sym "tau")) + ("upsilon" ,(sym "upsilon")) + ("phi" ,(sym "phi")) + ("chi" ,(sym "chi")) + ("psi" ,(sym "psi")) + ("omega" ,(sym "omega")) + ("thetasym" ,(sym "thetasym")) + ("piv" ,(sym "piv")) ;; FIXME! ;; punctuation - ("bullet" "{ @Sym bullet }") - ("ellipsis" "{ @Sym ellipsis }") + ("bullet" ,(sym "bullet")) + ("ellipsis" ,(sym "ellipsis")) ("weierp" "{ @Sym weierstrass }") - ("image" "{ @Sym Ifraktur }") - ("real" "{ @Sym Rfraktur }") - ("tm" "{ @Sym trademarksans }") ;; alt: @Sym trademarkserif - ("alef" "{ @Sym aleph }") - ("<-" "{ @Sym arrowleft }") + ("image" ,(sym "Ifraktur")) + ("real" ,(sym "Rfraktur")) + ("tm" ,(sym "trademarksans")) ;; alt: @Sym trademarkserif + ("alef" ,(sym "aleph")) + ("<-" ,(sym "arrowleft")) ("<--" "{ { 1.6 1 } @Scale { @Sym arrowleft } }") ;; copied from `eqf' - ("uparrow" "{ @Sym arrowup }") - ("->" "{ @Sym arrowright }") + ("uparrow" ,(sym "arrowup")) + ("->" ,(sym "arrowright")) ("-->" "{ { 1.6 1 } @Scale { @Sym arrowright } }") - ("downarrow" "{ @Sym arrowdown }") - ("<->" "{ @Sym arrowboth }") + ("downarrow" ,(sym "arrowdown")) + ("<->" ,(sym "arrowboth")) ("<-->" "{ { 1.6 1 } @Scale { @Sym arrowboth } }") - ("<+" "{ @Sym carriagereturn }") - ("<=" "{ @Sym arrowdblleft }") + ("<+" ,(sym "carriagereturn")) + ("<=" ,(sym "arrowdblleft")) ("<==" "{ { 1.6 1 } @Scale { @Sym arrowdblleft } }") - ("Uparrow" "{ @Sym arrowdblup }") - ("=>" "{ @Sym arrowdblright }") + ("Uparrow" ,(sym "arrowdblup")) + ("=>" ,(sym "arrowdblright")) ("==>" "{ { 1.6 1 } @Scale { @Sym arrowdblright } }") - ("Downarrow" "{ @Sym arrowdbldown }") - ("<=>" "{ @Sym arrowdblboth }") + ("Downarrow" ,(sym "arrowdbldown")) + ("<=>" ,(sym "arrowdblboth")) ("<==>" "{ { 1.6 1 } @Scale { @Sym arrowdblboth } }") ;; Mathematical operators (we try to avoid `@Eq' since it ;; requires to `@SysInclude { eq }' -- one solution consists in copying ;; the symbol definition from `eqf') ("forall" "{ { Symbol Base } @Font \"\\042\" }") - ("partial" "{ @Sym partialdiff }") + ("partial" ,(sym "partialdiff")) ("exists" "{ { Symbol Base } @Font \"\\044\" }") ("emptyset" "{ { Symbol Base } @Font \"\\306\" }") - ("infinity" "{ @Sym infinity }") + ("infinity" ,(sym "infinity")) ("nabla" "{ { Symbol Base } @Font \"\\321\" }") - ("in" "{ @Sym element }") - ("notin" "{ @Sym notelement }") + ("in" ,(sym "element")) + ("notin" ,(sym "notelement")) ("ni" "{ 180d @Rotate @Sym element }") - ("prod" "{ @Sym product }") - ("sum" "{ @Sym summation }") - ("asterisk" "{ @Sym asteriskmath }") - ("sqrt" "{ @Sym radical }") + ("prod" ,(sym "product")) + ("sum" ,(sym "summation")) + ("asterisk" ,(sym "asteriskmath")) + ("sqrt" ,(sym "radical")) ("propto" ,(math "propto")) - ("angle" "{ @Sym angle }") + ("angle" ,(sym "angle")) ("and" ,(math "bwedge")) ("or" ,(math "bvee")) ("cap" ,(math "bcap")) @@ -297,33 +299,33 @@ ("models" ,(math "models")) ("vdash" ,(math "vdash")) ("dashv" ,(math "dashv")) - ("sim" "{ @Sym similar }") - ("cong" "{ @Sym congruent }") - ("approx" "{ @Sym approxequal }") - ("neq" "{ @Sym notequal }") - ("equiv" "{ @Sym equivalence }") - ("le" "{ @Sym lessequal }") - ("ge" "{ @Sym greaterequal }") - ("subset" "{ @Sym propersubset }") - ("supset" "{ @Sym propersuperset }") - ("subseteq" "{ @Sym reflexsubset }") - ("supseteq" "{ @Sym reflexsuperset }") - ("oplus" "{ @Sym circleplus }") - ("otimes" "{ @Sym circlemultiply }") - ("perp" "{ @Sym perpendicular }") - ("mid" "{ @Sym bar }") - ("lceil" "{ @Sym bracketlefttp }") - ("rceil" "{ @Sym bracketrighttp }") - ("lfloor" "{ @Sym bracketleftbt }") - ("rfloor" "{ @Sym bracketrightbt }") - ("langle" "{ @Sym angleleft }") - ("rangle" "{ @Sym angleright }") + ("sim" ,(sym "similar")) + ("cong" ,(sym "congruent")) + ("approx" ,(sym "approxequal")) + ("neq" ,(sym "notequal")) + ("equiv" ,(sym "equivalence")) + ("le" ,(sym "lessequal")) + ("ge" ,(sym "greaterequal")) + ("subset" ,(sym "propersubset")) + ("supset" ,(sym "propersuperset")) + ("subseteq" ,(sym "reflexsubset")) + ("supseteq" ,(sym "reflexsuperset")) + ("oplus" ,(sym "circleplus")) + ("otimes" ,(sym "circlemultiply")) + ("perp" ,(sym "perpendicular")) + ("mid" ,(sym "bar")) + ("lceil" ,(sym "bracketlefttp")) + ("rceil" ,(sym "bracketrighttp")) + ("lfloor" ,(sym "bracketleftbt")) + ("rfloor" ,(sym "bracketrightbt")) + ("langle" ,(sym "angleleft")) + ("rangle" ,(sym "angleright")) ;; Misc ("loz" "{ @Lozenge }") - ("spades" "{ @Sym spade }") - ("clubs" "{ @Sym club }") - ("hearts" "{ @Sym heart }") - ("diams" "{ @Sym diamond }") + ("spades" ,(sym "spade")) + ("clubs" ,(sym "club")) + ("hearts" ,(sym "heart")) + ("diams" ,(sym "diamond")) ("euro" "{ @Euro }") ;; Lout ("dag" "{ @Dagger }") @@ -348,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 '((#\, "-") @@ -691,6 +693,11 @@ :symbol-table (lout-symbol-table (lambda (m) + ;; We don't use `@Sym' because it doesn't + ;; work within `@Eq'. + (string-append "{ { Symbol Base } @Font " + "@Char \"" m "\" }")) + (lambda (m) (format #f "@Eq { ~a }\n" m))))) @@ -775,7 +782,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" @@ -784,7 +791,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 @@ -844,7 +851,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 @@ -2313,6 +2320,8 @@ ;; option trick. FIXME: This would be much more efficient if ;; `ast-parent' would work as expected. +;; FIXME: See whether `@II' can be useful. Use SRFI-39 parameters. + (markup-writer 'it :before (lambda (node engine) (let ((bold-children (search-down (lambda (n) @@ -2780,6 +2789,8 @@ ;* Illustrations */ ;*---------------------------------------------------------------------*/ (define-public (lout-illustration . args) + ;; FIXME: This should be a markup. + ;; Introduce a Lout illustration (such as a diagram) whose code is either ;; the body of `lout-illustration' or the contents of `file'. For engines ;; other than Lout, an EPS file is produced and then converted if needed. @@ -2833,138 +2844,41 @@ (file-contents file)))) (if (engine-format? "lout") (! contents) ;; simply inline the illustration - (cond-expand - (bigloo - (let* ((lout (find-engine 'lout)) - (output (string-append (or ident - (symbol->string - (gensym 'lout-illustration))) - ".eps")) - (proc (run-process (or (engine-custom lout - 'lout-program-name) - "lout") - "-o" output - "-EPS" - input: pipe:)) - (port (process-input-port proc))) - - ;; send the illustration to Lout's standard input - (display (illustration-header) port) - (display contents port) - (display (illustration-ending) port) - (close-output-port port) - - (process-wait proc) - (if (not (= 0 (process-exit-status proc))) + (let* ((lout (find-engine 'lout)) + (output (string-append (or ident + (symbol->string + (gensym 'lout-illustration))) + ".eps")) + (port (open-output-pipe + (string-append (or (engine-custom lout + 'lout-program-name) + "lout") + " -o " output + " -EPS")))) + + ;; send the illustration to Lout's standard input + (display (illustration-header) port) + (display contents port) + (display (illustration-ending) port) + + (let ((exit-val (status:exit-val (close-pipe port)))) + (if (not (eqv? 0 exit-val)) (skribe-error 'lout-illustration - "lout exited with error code" - (process-exit-status proc))) - (if (not (file-exists? output)) - (skribe-error 'lout-illustration "file not created" - output)) - (if (= 0 (file-size output)) - (skribe-error 'lout-illustration - "empty output file" output)) - - ;; the image - (image :file output alt))) - - (else ;; Unfortunately, chances are low that STklos has the same - ;; process API as the one Bigloo has. - (skribe-error 'lout - "lout-illustration: Not implemented" file))))))) - - -;*---------------------------------------------------------------------*/ -;* 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) + "lout exited with error code" exit-val))) - :validate (lambda (n e) - (eq? (engine-custom e 'document-type) 'slides)) + (if (not (file-exists? output)) + (skribe-error 'lout-illustration "file not created" + output)) - :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)) + (let ((file-info (false-if-exception (stat output)))) + (if (or (not file-info) + (= 0 (stat:size file-info))) + (skribe-error 'lout-illustration + "empty output file" output))) - :after "@End @Overhead\n") + ;; the image (FIXME: Should set its location) + (image :file output alt)))))) -(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/module.scm b/src/guile/skribilo/module.scm index 3ec0e7f..84cd078 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -63,10 +63,14 @@ (define %skribilo-user-autoloads ;; List of auxiliary modules that may be lazily autoloaded. - '(((skribilo engine lout) . (lout-illustration + '(((skribilo engine lout) . (!lout + lout-illustration ;; FIXME: The following should eventually be ;; removed from here. lout-structure-number-string)) + ((skribilo engine latex) . (!latex LaTeX TeX)) + ((skribilo engine html) . (html-markup-class html-class + html-width)) ((skribilo source) . (source-read-lines source-fontify language? language-extractor language-fontifier source-fontify)) diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am index 6e047d3..6cb30b9 100644 --- a/src/guile/skribilo/package/Makefile.am +++ b/src/guile/skribilo/package/Makefile.am @@ -1,4 +1,7 @@ guilemoduledir = $(GUILE_SITE)/skribilo/package dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \ lncs.scm scribe.scm sigplan.scm skribe.scm \ - slide.scm web-article.scm web-book.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 new file mode 100644 index 0000000..687a3f5 --- /dev/null +++ b/src/guile/skribilo/package/eq.scm @@ -0,0 +1,243 @@ +;;; eq.scm -- An equation formatting package. +;;; +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-module (skribilo package eq) + :autoload (skribilo ast) (markup?) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo module) + :use-module (skribilo skribe utils) ;; `the-options', etc. + :use-module (ice-9 optargs)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This package defines a set of markups for formatting equations. The user +;;; may either use the standard Scheme prefix notation to represent +;;; equations, or directly use the specific markups (which looks more +;;; verbose). +;;; +;;; FIXME: This is incomplete. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Utilities. +;;; + +(define %operators + '(/ * + - = != ~= < > <= >= sqrt expt sum product script + in notin apply)) + +(define %symbols + ;; A set of symbols that are automatically recognized within an `eq' quoted + ;; list. + '(;; lower-case Greek + alpha beta gamma delta epsilon zeta eta theta iota kappa + lambda mu nu xi omicron pi rho sigma tau upsilon phi chi omega + + ;; upper-case Greek + Alpha Beta Gamma Delta Epsilon Zeta Eta Theta Iota Kappa + Lambda Mu Nu Xi Omicron Pi Rho Sigma Tau Upsilon Phi Chi Omega + + ;; Hebrew + alef + + ;; mathematics + ellipsis weierp image real forall partial exists + emptyset infinity in notin nabla nipropto angle and or cap cup + sim cong approx neq equiv le ge subset supset subseteq supseteq + oplus otimes perp mid lceil rceil lfloor rfloor langle rangle)) + +(define %rebindings + (map (lambda (sym) + (list sym (symbol-append 'eq: sym))) + %operators)) + +(define (make-fast-member-predicate lst) + (let ((h (make-hash-table))) + ;; initialize a hash table equivalent to LST + (for-each (lambda (s) (hashq-set! h s #t)) lst) + + ;; the run-time, fast, definition + (lambda (sym) + (hashq-ref h sym #f)))) + +(define-public known-operator? (make-fast-member-predicate %operators)) +(define-public known-symbol? (make-fast-member-predicate %symbols)) + +(define-public (equation-markup? m) + "Return true if @var{m} is an instance of one of the equation sub-markups." + (define eq-sym? + (make-fast-member-predicate (map (lambda (s) + (symbol-append 'eq: s)) + %operators))) + (and (markup? m) + (eq-sym? (markup-markup m)))) + + +(define (eq:symbols->strings equation) + "Turn symbols located in non-@code{car} positions into strings." + (cond ((list? equation) + (if (or (null? equation) (null? (cdr equation))) + equation + (cons (car equation) ;; XXX: not tail-recursive + (map eq:symbols->strings (cdr equation))))) + ((symbol? equation) + (if (known-symbol? equation) + `(symbol ,(symbol->string equation)) + (symbol->string equation))) + (else equation))) + +(define-public (eq-evaluate equation) + "Evaluate @var{equation}, an sexp (list) representing an equation, e.g. +@code{'(+ a (/ b 3))}." + (eval `(let ,%rebindings ,(eq:symbols->strings equation)) + (current-module))) + + +;;; +;;; Markup. +;;; + +(define-markup (eq :rest opts :key (ident #f) (class "eq")) + (new markup + (markup 'eq) + (ident (or ident (symbol->string (gensym "eq")))) + (options (the-options opts)) + (body (let loop ((body (the-body opts)) + (result '())) + (if (null? body) + result + (loop (cdr body) + (if (markup? (car body)) + (car body) ;; the `eq:*' markups were used + ;; directly + (eq-evaluate (car body))) ;; a quoted list was + ;; passed + )))))) + +(define-simple-markup eq:/) +(define-simple-markup eq:*) +(define-simple-markup eq:+) +(define-simple-markup eq:-) + +(define-simple-markup eq:=) +(define-simple-markup eq:!=) +(define-simple-markup eq:~=) +(define-simple-markup eq:<) +(define-simple-markup eq:>) +(define-simple-markup eq:>=) +(define-simple-markup eq:<=) + +(define-simple-markup eq:sqrt) +(define-simple-markup eq:expt) + +(define-markup (eq:sum :rest opts :key (ident #f) (class "eq:sum") + (from #f) (to #f)) + (new markup + (markup 'eq:sum) + (ident (or ident (symbol->string (gensym "eq:sum")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (eq:product :rest opts :key (ident #f) (class "eq:product") + (from #f) (to #f)) + (new markup + (markup 'eq:product) + (ident (or ident (symbol->string (gensym "eq:product")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (eq:script :rest opts :key (ident #f) (class "eq:script") + (sub #f) (sup #f)) + (new markup + (markup 'eq:script) + (ident (or ident (symbol->string (gensym "eq:script")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-simple-markup eq:in) +(define-simple-markup eq:notin) + +(define-markup (eq:apply :rest opts :key (ident #f) (class "eq:apply")) + ;; This markup may receive either a list of arguments or arguments + ;; compatible with the real `apply'. Note: the real `apply' can take N + ;; non-list arguments but the last one has to be a list. + (new markup + (markup 'eq:apply) + (ident (or ident (symbol->string (gensym "eq:apply")))) + (options (the-options opts)) + (body (let loop ((body (the-body opts)) + (result '())) + (if (null? body) + (reverse! result) + (let ((first (car body))) + (if (list? first) + (if (null? (cdr body)) + (append (reverse! result) first) + (skribe-error 'eq:apply + "wrong argument type" + body)) + (loop (cdr body) (cons first result))))))))) + + +;;; +;;; Text-only implementation. +;;; + +(markup-writer 'eq (find-engine 'base) + :action (lambda (node engine) + (output (apply it (markup-body node)) engine))) + +(markup-writer 'eq:/ (find-engine 'base) + :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 " / ")) + (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..bd2ccf4 --- /dev/null +++ b/src/guile/skribilo/package/eq/lout.scm @@ -0,0 +1,206 @@ +;;; lout.scm -- Lout implementation of the `eq' package. +;;; +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(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 >=) + +(define-macro (binary-lout-markup-writer sym lout-name) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (let* ((first (car body)) + (second (cadr body)) + (parentheses? (equation-markup? first))) + (display " { { ") + (if parentheses? (display "(")) + (output first engine) + (if parentheses? (display ")")) + (display ,(string-append " } " lout-name " { ")) + (output second engine) + (display " } } ")) + (skribe-error ,(symbol-append 'eq: sym) + "wrong number of arguments" + body)))))) + +(binary-lout-markup-writer expt "sup") +(binary-lout-markup-writer in "element") +(binary-lout-markup-writer notin "notelement") + +(markup-writer 'eq:apply (find-engine 'lout) + :action (lambda (node engine) + (let ((func (car (markup-body node)))) + (output func engine) + (display "(") + (let loop ((operands (cdr (markup-body node)))) + (if (null? operands) + #t + (begin + (output (car operands) engine) + (if (not (null? (cdr operands))) + (display ", ")) + (loop (cdr operands))))) + (display ")")))) + + + +;;; +;;; 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 ddbbd1d..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 <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + (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 "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" - (html-width (slide-body-width e))) - (if (string? tbg) - (printf "<td bgcolor=\"~a\">" tbg) - (display "<td>")) - (if (string? tfg) - (printf "<font color=\"~a\">" tfg)) - (if title - (begin - (display "<center>") - (if (string? tfont) - (begin - (printf "<font ~a><strong>" tfont) - (output title e) - (display "</strong></font>")) - (begin - (printf "<div class=\"skribetitle\"><strong><big><big><big>") - (output title e) - (display "</big></big></big></strong</div>"))) - (display "</center>\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "</font>")) - (display "</td></tr></tbody></table></center>\n"))) ;*---------------------------------------------------------------------*/ ;* slide-number ... */ ;*---------------------------------------------------------------------*/ -(define (slide-number) +(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 "<a name=\"~a\">" (markup-ident n)) - (display "<br>\n")) - :action (lambda (n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (skribe-eval - (center - (color :width (slide-body-width e) - :bg (or (markup-option n :bg) "#ffffff") - (table :width 100. - (tr (th :align 'left - (list - (if nb - (format "~a / ~a -- " nb - (slide-number))) - t))) - (tr (td (hrule))) - (tr (td :width 100. :align 'left - (markup-body n)))) - (linebreak))) - e))) - :after "<br>") - ;; slide-vspace - (markup-writer 'slide-vspace he - :action (lambda (n e) (display "<br>")))) - -;*---------------------------------------------------------------------*/ -;* latex */ -;*---------------------------------------------------------------------*/ -(define &latex-slide #f) -(define &latex-pause #f) -(define &latex-embed #f) -(define &latex-record #f) -(define &latex-play #f) -(define &latex-play* #f) - -;;; 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 "~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 "<a name=\"~a\">" (markup-ident n)) + (display "<br>\n")) + :action (lambda (n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (skribe-eval + (center + (color :width (slide-body-width e) + :bg (or (markup-option n :bg) "#ffffff") + (table :width 100. + (tr (th :align 'left + (list + (if nb + (format #f "~a / ~a -- " nb + (slide-number))) + t))) + (tr (td (hrule))) + (tr (td :width 100. :align 'left + (markup-body n)))) + (linebreak))) + e))) + :after "<br>") + ;; slide-vspace + (markup-writer 'slide-vspace he + :action (lambda (n e) (display "<br>"))))) + +;*---------------------------------------------------------------------*/ +;* slide-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (slide-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 95.))) + +;*---------------------------------------------------------------------*/ +;* html-slide-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-slide-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" + (html-width (slide-body-width e))) + (if (string? tbg) + (printf "<td bgcolor=\"~a\">" tbg) + (display "<td>")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (if title + (begin + (display "<center>") + (if (string? tfont) + (begin + (printf "<font ~a><strong>" tfont) + (output title e) + (display "</strong></font>")) + (begin + (printf "<div class=\"skribetitle\"><strong><big><big><big>") + (output title e) + (display "</big></big></big></strong</div>"))) + (display "</center>\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table></center>\n"))) + + +;;; 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 <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(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/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm index f24c2f7..f92f13b 100644 --- a/src/guile/skribilo/reader/skribe.scm +++ b/src/guile/skribilo/reader/skribe.scm @@ -65,25 +65,18 @@ the Skribe syntax." (let ((colon-keywords ;; keywords à la `:key' fashion (r:make-token-reader #\: (r:token-reader-procedure - (r:standard-token-reader 'keyword)))) - (square-bracket-free-symbol-misc-chars - (let* ((tr (r:standard-token-reader 'guile-symbol-misc-chars)) - (tr-spec (r:token-reader-specification tr)) - (tr-proc (r:token-reader-procedure tr))) - (r:make-token-reader (filter (lambda (chr) - (not (or (eq? chr #\[) - (eq? chr #\])))) - tr-spec) - tr-proc)))) + (r:standard-token-reader 'keyword))))) + ;; Note: we use the `r6rs-symbol-*' and `r6rs-number' token readers since + ;; they consider square brackets as delimiters. (r:make-reader (cons* (r:make-token-reader #\# &sharp-reader) colon-keywords - square-bracket-free-symbol-misc-chars (map r:standard-token-reader `(whitespace - sexp string guile-number - guile-symbol-lower-case - guile-symbol-upper-case + sexp string r6rs-number + r6rs-symbol-lower-case + r6rs-symbol-upper-case + r6rs-symbol-misc-chars quote-quasiquote-unquote semicolon-comment skribe-exp))) diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm index e302ee9..bd8497f 100644 --- a/src/guile/skribilo/runtime.scm +++ b/src/guile/skribilo/runtime.scm @@ -1,8 +1,7 @@ -;;; ;;; runtime.scm -- Skribilo runtime system ;;; -;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> -;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -35,15 +34,11 @@ :use-module (skribilo lib) :use-module (srfi srfi-13) :use-module (srfi srfi-35) + :autoload (skribilo utils files) (file-prefix file-suffix) :autoload (skribilo condition) (&file-search-error) :autoload (srfi srfi-34) (raise)) -(define (suffix path) - (let ((dot (string-rindex path #\.))) - (if (not dot) - path - (substring path (+ dot 1) (string-length path))))) ;;; ====================================================================== ;;; @@ -108,8 +103,8 @@ ;;; ;;; ====================================================================== (define (builtin-convert-image from fmt dir) - (let* ((s (suffix from)) - (f (string-append (prefix (basename from)) "." fmt)) + (let* ((s (file-suffix from)) + (f (string-append (file-prefix (basename from)) "." fmt)) (to (string-append dir "/" f))) ;; FIXME: (cond ((string=? s fmt) @@ -133,7 +128,7 @@ (if (not path) (raise (condition (&file-search-error (file-name file) (path (*image-path*))))) - (let ((suf (suffix file))) + (let ((suf (file-suffix file))) (if (member suf formats) (let* ((dir (if (string? (*destination-file*)) (dirname (*destination-file*)) diff --git a/src/guile/skribilo/utils/Makefile.am b/src/guile/skribilo/utils/Makefile.am index 6a82ac7..5044c1b 100644 --- a/src/guile/skribilo/utils/Makefile.am +++ b/src/guile/skribilo/utils/Makefile.am @@ -1,4 +1,4 @@ guilemoduledir = $(GUILE_SITE)/skribilo/utils -dist_guilemodule_DATA = syntax.scm compat.scm +dist_guilemodule_DATA = syntax.scm compat.scm files.scm ## arch-tag: 3a18b64b-1da2-417b-8338-2c534bca277f diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm index a7ce781..9ed9f3e 100644 --- a/src/guile/skribilo/utils/compat.scm +++ b/src/guile/skribilo/utils/compat.scm @@ -21,6 +21,7 @@ (define-module (skribilo utils compat) :use-module (skribilo utils syntax) + :use-module (skribilo utils files) :use-module (skribilo parameters) :use-module (skribilo evaluator) :use-module (srfi srfi-1) @@ -30,6 +31,7 @@ :use-module (ice-9 optargs) :autoload (skribilo ast) (ast?) :autoload (skribilo condition) (file-search-error? &file-search-error) + :re-export (file-size) :replace (gensym)) ;;; Author: Ludovic Courtès @@ -134,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) @@ -197,19 +197,6 @@ (for-each display args) (display "\n"))))) -(define-public (file-prefix fn) - (if fn - (let ((dot (string-rindex fn #\.))) - (if dot (substring fn 0 dot) fn)) - "./SKRIBILO-OUTPUT")) - -(define-public (file-suffix fn) - (if fn - (let ((dot (string-rindex fn #\.))) - (if dot - (substring fn (+ dot 1) (string-length fn)) - "")) - #f)) (define-public prefix file-prefix) diff --git a/src/guile/skribilo/utils/files.scm b/src/guile/skribilo/utils/files.scm new file mode 100644 index 0000000..7eb1cf2 --- /dev/null +++ b/src/guile/skribilo/utils/files.scm @@ -0,0 +1,55 @@ +;;; files.scm -- File-related utilities. +;;; +;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-module (skribilo utils files) + :export (file-prefix file-suffix file-size)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module defines filesystem-related utility functions. +;;; +;;; Code: + +(define (file-size file) + (let ((file-info (false-if-exception (stat file)))) + (if file-info + (stat:size file-info) + #f))) + +(define (file-prefix fn) + (if fn + (let ((dot (string-rindex fn #\.))) + (if dot (substring fn 0 dot) fn)) + "./SKRIBILO-OUTPUT")) + +(define (file-suffix fn) + (if fn + (let ((dot (string-rindex fn #\.))) + (if dot + (substring fn (+ dot 1) (string-length fn)) + "")) + #f)) + + +;;; arch-tag: b63d2a9f-a254-4e2d-8d85-df773bbc4a9b + +;;; files.scm ends here diff --git a/src/skribilo.in b/src/skribilo.in index 952784a..7d3a78d 100755 --- a/src/skribilo.in +++ b/src/skribilo.in @@ -1,6 +1,6 @@ #!/bin/sh -# Copyright 2005,2006 Ludovic Courtès <ludovic.courtes@laas.fr> +# Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> # # # This program is free software; you can redistribute it and/or modify @@ -20,15 +20,18 @@ # The `skribilo' executable. +# Note: In Guile 1.8+ (or 1.9), when Guile is run in batch mode with +# `--debug', it produces a clean stack trace when an exception is +# raised and uncaught. On earlier versions, it behaves as if +# `--debug' had not been passed, not displaying a stack trace. See +# http://lists.gnu.org/archive/html/guile-devel/2006-01/msg00022.html +# for details. + main='(module-ref (resolve-module '\''(skribilo)) '\'main')' exec ${GUILE-@GUILE@} --debug \ -c " (use-modules (skribilo condition)) -(catch #t (lambda () - (call-with-skribilo-error-catch - (lambda () - (apply $main (cdr (command-line)))))) - (lambda (key . args) - (format (current-error-port) \"exception \`~a' raised~%\" key) - (exit 1)))" "$@" +(call-with-skribilo-error-catch + (lambda () + (apply $main (cdr (command-line)))))" "$@" |