diff options
Diffstat (limited to 'src/guile/skribilo/package/slide.scm')
| -rw-r--r-- | src/guile/skribilo/package/slide.scm | 274 |
1 files changed, 274 insertions, 0 deletions
diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm new file mode 100644 index 0000000..7f731e3 --- /dev/null +++ b/src/guile/skribilo/package/slide.scm @@ -0,0 +1,274 @@ +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-skribe-module (skribilo package slide)) + + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define-public &slide-load-options (skribe-load-options)) + + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) + +;*---------------------------------------------------------------------*/ +;* slide ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide #!rest opt + #!key + (ident #f) (class #f) + (toc #t) + title (number #t) + (vspace #f) (vfill #f) + (transition #f) + (bg #f) (image #f)) + (let ((s (new container + (markup 'slide) + (ident (if (not ident) + (symbol->string (gensym 'slide)) + ident)) + (class class) + (required-options '(:title :number :toc)) + (options `((:number + ,(cond + ((number? number) + (set! %slide-the-counter number) + number) + (number + (set! %slide-the-counter + (+ 1 %slide-the-counter)) + %slide-the-counter) + (else + #f))) + (:toc ,toc) + ,@(the-options opt :ident :class :vspace :toc))) + (body (if vspace + (list (slide-vspace vspace) (the-body opt)) + (the-body opt)))))) + (set! %slide-the-slides (cons s %slide-the-slides)) + s)) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define %slide-old-ref ref) + +;; Extend the definition of `ref'. +;; FIXME: This technique breaks `ref' for some reason. +; (set! ref +; (lambda args +; ;; Filter out ARGS and look for a `:slide' keyword argument. +; (let loop ((slide #f) +; (opt '()) +; (args args)) +; (if (null? args) +; (set! opt (reverse! opt)) +; (let ((s? (eq? (car args) :slide))) +; (loop (if s? (cadr args) #f) +; (if s? opt (cons (car args) opt)) +; (if s? (cddr args) (cdr args))))) + +; (format (current-error-port) +; "slide.scm:ref: slide=~a opt=~a~%" slide opt) + +; (if (not slide) +; (apply %slide-old-ref opt) +; (new unresolved +; (proc (lambda (n e env) +; (cond +; ((eq? slide 'next) +; (let ((c (assq n %slide-the-slides))) +; (if (pair? c) +; (handle (cadr c)) +; #f))) +; ((eq? slide 'prev) +; (let ((c (assq n (reverse %slide-the-slides)))) +; (if (pair? c) +; (handle (cadr c)) +; #f))) +; ((number? slide) +; (let loop ((s %slide-the-slides)) +; (cond +; ((null? s) +; #f) +; ((= slide (markup-option +; (car s) :number)) +; (handle (car s))) +; (else +; (loop (cdr s)))))) +; (else +; #f))))))))) + + +;*---------------------------------------------------------------------*/ +;* slide-pause ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-pause) + (new markup + (markup 'slide-pause))) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) + (new markup + (markup 'slide-vspace) + (options `((:unit ,unit) ,@(the-options opt :unit))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-embed #!rest opt + #!key + command + (geometry-opt "-geometry") + (geometry #f) (rgeometry #f) + (transient #f) (transient-opt #f) + (alt #f) + &skribe-eval-location) + (if (not (string? command)) + (skribe-error 'slide-embed + "No command provided" + command) + (new markup + (markup 'slide-embed) + (loc &skribe-eval-location) + (required-options '(:alt)) + (options `((:geometry-opt ,geometry-opt) + (:alt ,alt) + ,@(the-options opt :geometry-opt :alt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-record ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) + (if (not tag) + (skribe-error 'slide-record "Tag missing" tag) + (new markup + (markup 'slide-record) + (ident ident) + (class class) + (options `((:play ,play) ,@(the-options opt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play #!rest opt #!key ident class tag color) + (if (not tag) + (skribe-error 'slide-play "Tag missing" tag) + (new markup + (markup 'slide-play) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + ,@(the-options opt :color))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play* ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play* #!rest opt + #!key ident class color (scolor "#000000")) + (let ((body (the-body opt))) + (for-each (lambda (lbl) + (match-case lbl + ((?id ?col) + (skribe-use-color! col)))) + body) + (new markup + (markup 'slide-play*) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + (:scolor ,(if color (skribe-use-color! scolor) #f)) + ,@(the-options opt :color :scolor))) + (body body)))) + + + +;*---------------------------------------------------------------------*/ +;* slide-number ... */ +;*---------------------------------------------------------------------*/ +(define-public (slide-number) + (length (filter (lambda (n) + (and (is-markup? n 'slide) + (markup-option n :number))) + %slide-the-slides))) + +;*---------------------------------------------------------------------*/ +;* slide-topic ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-topic #!rest opt + #!key title (outline? #t) + (ident #f) (class "slide-topic")) + (new container + (markup 'slide-topic) + (required-options '(:title :outline?)) + (ident (or ident (symbol->string (gensym 'slide-topic)))) + (options `((:outline? ,outline?) + ,@(the-options opt :outline?))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-subtopic ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-subtopic #!rest opt + #!key title (outline? #f) + (ident #f) (class "slide-subtopic")) + (new container + (markup 'slide-subtopic) + (required-options '(:title :outline?)) + (ident (or ident (symbol->string (gensym 'slide-subtopic)))) + (options `((:outline? ,outline?) + ,@(the-options opt :outline?))) + (body (the-body opt)))) + + + +;;; +;;; Initialization. +;;; + +(format (current-error-port) "Slides initializing...~%") + +;; Register specific implementations for lazy loading. +(when-engine-is-loaded 'base + (lambda () + (resolve-module '(skribilo package slide base)))) +(when-engine-is-loaded 'latex + (lambda () + (resolve-module '(skribilo package slide latex)))) +(when-engine-is-loaded 'html + (lambda () + (resolve-module '(skribilo package slide html)))) +(when-engine-is-loaded 'lout + (lambda () + (resolve-module '(skribilo package slide lout)))) + |