diff options
Diffstat (limited to 'skr/slide.skr')
| -rw-r--r-- | skr/slide.skr | 664 |
1 files changed, 664 insertions, 0 deletions
diff --git a/skr/slide.skr b/skr/slide.skr new file mode 100644 index 0000000..f8638ad --- /dev/null +++ b/skr/slide.skr @@ -0,0 +1,664 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/slide.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for slides */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define &slide-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-predocument + "\\special{landscape} + \\slideframe{none} + \\centerslidesfalse + \\raggedslides[0pt] + \\renewcommand{\\slideleftmargin}{0.2in} + \\renewcommand{\\slidetopmargin}{0.3in} + \\newdimen\\slidewidth \\slidewidth 9in") + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-maketitle ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-maketitle + "\\def\\labelitemi{$\\bullet$} + \\def\\labelitemii{$\\circ$} + \\def\\labelitemiii{$\\diamond$} + \\def\\labelitemiv{$\\cdot$} + \\pagestyle{empty} + \\slideframe{none} + \\centerslidestrue + \\begin{slide} + \\date{} + \\maketitle + \\end{slide} + \\slideframe{none} + \\centerslidesfalse") + +;*---------------------------------------------------------------------*/ +;* &slide-prosper-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-prosper-predocument + "\\slideCaption{}\n") + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) +(define %slide-initialized #f) +(define %slide-latex-mode 'seminar) + +;*---------------------------------------------------------------------*/ +;* %slide-initialize! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-initialize!) + (unless %slide-initialized + (set! %slide-initialized #t) + (case %slide-latex-mode + ((seminar) + (%slide-seminar-setup!)) + ((advi) + (%slide-advi-setup!)) + ((prosper) + (%slide-prosper-setup!)) + (else + (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) + +;*---------------------------------------------------------------------*/ +;* slide ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide #!rest opt + #!key + (ident #f) (class #f) + (toc #t) + title (number #t) + (vspace #f) (vfill #f) + (transition #f) + (bg #f) (image #f)) + (%slide-initialize!) + (let ((s (new container + (markup 'slide) + (ident (symbol->string (gensym 'slide))) + (class class) + (required-options '(:title :number :toc)) + (options `((:number + ,(cond + ((number? number) + (set! %slide-the-counter number) + number) + (number + (set! %slide-the-counter + (+ 1 %slide-the-counter)) + %slide-the-counter) + (else + #f))) + (:toc ,toc) + ,@(the-options opt :ident :class :vspace :toc))) + (body (if vspace + (list (slide-vspace vspace) (the-body opt)) + (the-body opt)))))) + (set! %slide-the-slides (cons s %slide-the-slides)) + s)) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define %slide-old-ref ref) + +(define-markup (ref #!rest opt #!key (slide #f)) + (if (not slide) + (apply %slide-old-ref opt) + (new unresolved + (proc (lambda (n e env) + (cond + ((eq? slide 'next) + (let ((c (assq n %slide-the-slides))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((eq? slide 'prev) + (let ((c (assq n (reverse %slide-the-slides)))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((number? slide) + (let loop ((s %slide-the-slides)) + (cond + ((null? s) + #f) + ((= slide (markup-option (car s) :number)) + (handle (car s))) + (else + (loop (cdr s)))))) + (else + #f))))))) + +;*---------------------------------------------------------------------*/ +;* slide-pause ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-pause) + (new markup + (markup 'slide-pause))) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) + (new markup + (markup 'slide-vspace) + (options `((:unit ,unit) ,@(the-options opt :unit))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-embed #!rest opt + #!key + command + (geometry-opt "-geometry") + (geometry #f) (rgeometry #f) + (transient #f) (transient-opt #f) + (alt #f) + &skribe-eval-location) + (if (not (string? command)) + (skribe-error 'slide-embed + "No command provided" + command) + (new markup + (markup 'slide-embed) + (loc &skribe-eval-location) + (required-options '(:alt)) + (options `((:geometry-opt ,geometry-opt) + (:alt ,alt) + ,@(the-options opt :geometry-opt :alt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-record ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) + (if (not tag) + (skribe-error 'slide-record "Tag missing" tag) + (new markup + (markup 'slide-record) + (ident ident) + (class class) + (options `((:play ,play) ,@(the-options opt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play #!rest opt #!key ident class tag color) + (if (not tag) + (skribe-error 'slide-play "Tag missing" tag) + (new markup + (markup 'slide-play) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + ,@(the-options opt :color))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play* ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play* #!rest opt + #!key ident class color (scolor "#000000")) + (let ((body (the-body opt))) + (for-each (lambda (lbl) + (match-case lbl + ((?id ?col) + (skribe-use-color! col)))) + body) + (new markup + (markup 'slide-play*) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + (:scolor ,(if color (skribe-use-color! scolor) #f)) + ,@(the-options opt :color :scolor))) + (body body)))) + +;*---------------------------------------------------------------------*/ +;* base */ +;*---------------------------------------------------------------------*/ +(let ((be (find-engine 'base))) + (skribe-message "Base slides setup...\n") + ;; slide-pause + (markup-writer 'slide-pause be + :action #f) + ;; slide-vspace + (markup-writer 'slide-vspace be + :options '() + :action #f) + ;; slide-embed + (markup-writer 'slide-embed be + :options '(:alt :geometry-opt) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-record + (markup-writer 'slide-record be + :options '(:tag :play) + :action (lambda (n e) + (output (markup-body n) e))) + ;; slide-play + (markup-writer 'slide-play be + :options '(:tag :color) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-play* + (markup-writer 'slide-play* be + :options '(:tag :color :scolor) + :action (lambda (n e) + (output (markup-option n :alt) e)))) + +;*---------------------------------------------------------------------*/ +;* slide-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (slide-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 95.))) + +;*---------------------------------------------------------------------*/ +;* html-slide-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-slide-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" + (html-width (slide-body-width e))) + (if (string? tbg) + (printf "<td bgcolor=\"~a\">" tbg) + (display "<td>")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (if title + (begin + (display "<center>") + (if (string? tfont) + (begin + (printf "<font ~a><strong>" tfont) + (output title e) + (display "</strong></font>")) + (begin + (printf "<div class=\"skribetitle\"><strong><big><big><big>") + (output title e) + (display "</big></big></big></strong</div>"))) + (display "</center>\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table></center>\n"))) + +;*---------------------------------------------------------------------*/ +;* slide-number ... */ +;*---------------------------------------------------------------------*/ +(define (slide-number) + (length (filter (lambda (n) + (and (is-markup? n 'slide) + (markup-option n :number))) + %slide-the-slides))) + +;*---------------------------------------------------------------------*/ +;* html */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (skribe-message "HTML slides setup...\n") + ;; &html-page-title + (markup-writer '&html-document-title he + :predicate (lambda (n e) %slide-initialized) + :action html-slide-title) + ;; slide + (markup-writer 'slide he + :options '(:title :number :transition :toc :bg) + :before (lambda (n e) + (printf "<a name=\"~a\">" (markup-ident n)) + (display "<br>\n")) + :action (lambda (n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (skribe-eval + (center + (color :width (slide-body-width e) + :bg (or (markup-option n :bg) "#ffffff") + (table :width 100. + (tr (th :align 'left + (list + (if nb + (format "~a / ~a -- " nb + (slide-number))) + t))) + (tr (td (hrule))) + (tr (td :width 100. :align 'left + (markup-body n)))) + (linebreak))) + e))) + :after "<br>") + ;; slide-vspace + (markup-writer 'slide-vspace he + :action (lambda (n e) (display "<br>")))) + +;*---------------------------------------------------------------------*/ +;* latex */ +;*---------------------------------------------------------------------*/ +(define &latex-slide #f) +(define &latex-pause #f) +(define &latex-embed #f) +(define &latex-record #f) +(define &latex-play #f) +(define &latex-play* #f) + +(let ((le (find-engine 'latex))) + ;; slide-vspace + (markup-writer 'slide-vspace le + :options '(:unit) + :action (lambda (n e) + (display "\n\\vspace{") + (output (markup-body n) e) + (printf " ~a}\n\n" (markup-option n :unit)))) + ;; slide-slide + (markup-writer 'slide le + :options '(:title :number :transition :vfill :toc :vspace :image) + :action (lambda (n e) + (if (procedure? &latex-slide) + (&latex-slide n e)))) + ;; slide-pause + (markup-writer 'slide-pause le + :options '() + :action (lambda (n e) + (if (procedure? &latex-pause) + (&latex-pause n e)))) + ;; slide-embed + (markup-writer 'slide-embed le + :options '(:alt :command :geometry-opt :geometry + :rgeometry :transient :transient-opt) + :action (lambda (n e) + (if (procedure? &latex-embed) + (&latex-embed n e)))) + ;; slide-record + (markup-writer 'slide-record le + :options '(:tag :play) + :action (lambda (n e) + (if (procedure? &latex-record) + (&latex-record n e)))) + ;; slide-play + (markup-writer 'slide-play le + :options '(:tag :color) + :action (lambda (n e) + (if (procedure? &latex-play) + (&latex-play n e)))) + ;; slide-play* + (markup-writer 'slide-play* le + :options '(:tag :color :scolor) + :action (lambda (n e) + (if (procedure? &latex-play*) + (&latex-play* n e))))) + +;*---------------------------------------------------------------------*/ +;* %slide-seminar-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-seminar-setup!) + (skribe-message "Seminar slides setup...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + ;; latex configuration + (define (seminar-slide n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (display "\\begin{slide}\n") + (if nb (printf "~a/~a -- " nb (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n")) + (engine-custom-set! le 'documentclass + "\\documentclass[landscape]{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'hyperref-usepackage + "\\usepackage[setpagesize=false]{hyperref}\n") + ;; slide-slide + (set! &latex-slide seminar-slide))) + +;*---------------------------------------------------------------------*/ +;* %slide-advi-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-advi-setup!) + (skribe-message "Generating `Advi Seminar' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + (define (advi-geometry geo) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) + (if (pair? r) + (let* ((w (cadr r)) + (w' (string->integer w)) + (w'' (number->string (/ w' *skribe-slide-advi-scale*))) + (h (caddr r)) + (h' (string->integer h)) + (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) + (values "" (string-append w "x" h "+!x+!y"))) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) + (if (pair? r) + (let ((w (number->string (/ (string->integer (cadr r)) + *skribe-slide-advi-scale*))) + (h (number->string (/ (string->integer (caddr r)) + *skribe-slide-advi-scale*))) + (x (cadddr r)) + (y (car (cddddr r)))) + (values (string-append "width=" w "cm,height=" h "cm") + "!g")) + (values "" geo)))))) + (define (advi-transition trans) + (cond + ((string? trans) + (printf "\\advitransition{~s}" trans)) + ((and (symbol? trans) + (memq trans '(wipe block slide))) + (printf "\\advitransition{~s}" trans)) + (else + #f))) + ;; latex configuration + (define (advi-slide n e) + (let ((i (markup-option n :image)) + (n (markup-option n :number)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition))) + (if (and i (engine-custom e 'advi)) + (printf "\\advibg[global]{image=~a}\n" + (if (and (pair? i) + (null? (cdr i)) + (string? (car i))) + (car i) + i))) + (display "\\begin{slide}\n") + (advi-transition (or lt gt)) + (if n (printf "~a/~a -- " n (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n\n\n")) + ;; advi record + (define (advi-record n e) + (display "\\advirecord") + (when (markup-option n :play) (display "[play]")) + (printf "{~a}{" (markup-option n :tag)) + (output (markup-body n) e) + (display "}")) + ;; advi play + (define (advi-play n e) + (display "\\adviplay") + (let ((c (markup-option n :color))) + (when c + (display "[") + (display (skribe-get-latex-color c)) + (display "]"))) + (printf "{~a}" (markup-option n :tag))) + ;; advi play* + (define (advi-play* n e) + (let ((c (skribe-get-latex-color (markup-option n :color))) + (d (skribe-get-latex-color (markup-option n :scolor)))) + (let loop ((lbls (markup-body n)) + (last #f)) + (when last + (display "\\adviplay[") + (display d) + (printf "]{~a}" last)) + (when (pair? lbls) + (let ((lbl (car lbls))) + (match-case lbl + ((?id ?col) + (display "\\adviplay[") + (display (skribe-get-latex-color col)) + (printf "]{" ~a "}" id) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) id)) + (else + (display "\\adviplay[") + (display c) + (printf "]{~a}" lbl) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) lbl)))))))) + (engine-custom-set! le 'documentclass + "\\documentclass{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'usepackage + (string-append "\\usepackage{advi}\n" + (engine-custom le 'usepackage))) + ;; slide + (set! &latex-slide advi-slide) + (set! &latex-pause + (lambda (n e) (display "\\adviwait\n"))) + (set! &latex-embed + (lambda (n e) + (let ((geometry-opt (markup-option n :geometry-opt)) + (geometry (markup-option n :geometry)) + (rgeometry (markup-option n :rgeometry)) + (transient (markup-option n :transient)) + (transient-opt (markup-option n :transient-opt)) + (cmd (markup-option n :command))) + (let* ((a (string-append "ephemeral=" + (symbol->string (gensym)))) + (c (cond + (geometry + (string-append cmd " " + geometry-opt " " + geometry)) + (rgeometry + (multiple-value-bind (aopt dopt) + (advi-geometry rgeometry) + (set! a (string-append a "," aopt)) + (string-append cmd " " + geometry-opt " " + dopt))) + (else + cmd))) + (c (if (and transient transient-opt) + (string-append c " " transient-opt " !p") + c))) + (printf "\\adviembed[~a]{~a}\n" a c))))) + (set! &latex-record advi-record) + (set! &latex-play advi-play) + (set! &latex-play* advi-play*))) + +;*---------------------------------------------------------------------*/ +;* %slide-prosper-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-prosper-setup!) + (skribe-message "Generating `Prosper' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base)) + (overlay-count 0)) + ;; transitions + (define (prosper-transition trans) + (cond + ((string? trans) + (printf "[~s]" trans)) + ((eq? trans 'slide) + (printf "[Blinds]")) + ((and (symbol? trans) + (memq trans '(split blinds box wipe dissolve glitter))) + (printf "[~s]" + (string-upcase (symbol->string trans)))) + (else + #f))) + ;; latex configuration + (define (prosper-slide n e) + (let* ((i (markup-option n :image)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition)) + (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) + (lpa (length pa))) + (set! overlay-count 1) + (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) + (display "\\begin{slide}") + (prosper-transition (or lt gt)) + (display "{") + (output t e) + (display "}\n") + (output (markup-body n) e) + (display "\\end{slide}\n") + (if (>= lpa 1) (display "}\n")) + (newline) + (newline))) + (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") + (let* ((cap (engine-custom le 'slide-caption)) + (o (engine-custom le 'predocument)) + (n (if (string? cap) + (format "~a\\slideCaption{~a}\n" + &slide-prosper-predocument + cap) + &slide-prosper-predocument))) + (engine-custom-set! le 'predocument + (if (string? o) (string-append n o) n))) + (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") + ;; writers + (set! &latex-slide prosper-slide) + (set! &latex-pause + (lambda (n e) + (set! overlay-count (+ 1 overlay-count)) + (printf "\\FromSlide{~s}%\n" overlay-count))))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &slide-load-options) + (p (memq :prosper opt))) + (if (and (pair? p) (pair? (cdr p)) (cadr p)) + ;; prosper + (set! %slide-latex-mode 'prosper) + (let ((a (memq :advi opt))) + (if (and (pair? a) (pair? (cdr a)) (cadr a)) + ;; advi + (set! %slide-latex-mode 'advi))))) + |