diff options
| -rw-r--r-- | src/guile/skribilo/package/slide.scm | 97 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide/Makefile.am | 2 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide/base.scm | 174 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide/html.scm | 28 | ||||
| -rw-r--r-- | src/guile/skribilo/package/slide/lout.scm | 16 |
5 files changed, 265 insertions, 52 deletions
diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm index 8c4582c..5a5f73d 100644 --- a/src/guile/skribilo/package/slide.scm +++ b/src/guile/skribilo/package/slide.scm @@ -20,8 +20,7 @@ ;;; USA. -(define-skribe-module (skribilo package slide) - :autoload (skribilo engine html) (html-width html-title-authors)) +(define-skribe-module (skribilo package slide)) ;*---------------------------------------------------------------------*/ @@ -37,23 +36,6 @@ (define %slide-the-counter 0) ;*---------------------------------------------------------------------*/ -;* %slide-initialize! ... */ -;*---------------------------------------------------------------------*/ -(format (current-error-port) "Slides initializing...~%") - -;; Register specific implementations for lazy loading. -(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)))) - - -;*---------------------------------------------------------------------*/ ;* slide ... */ ;*---------------------------------------------------------------------*/ (define-markup (slide #!rest opt @@ -229,38 +211,6 @@ ,@(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)))) ;*---------------------------------------------------------------------*/ @@ -271,3 +221,48 @@ (and (is-markup? n 'slide) (markup-option n :number))) %slide-the-slides))) + +;*---------------------------------------------------------------------*/ +;* slide-topic ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-topic #!rest opt + #!key (outline? #t) (title "") (ident #f)) + (new container + (markup 'slide-topic) + (ident (or ident (symbol->string (gensym 'slide-topic)))) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-subtopic ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-subtopic #!rest opt + #!key (outline? #f) (title "") (ident #f)) + (new container + (markup 'slide-subtopic) + (ident (or ident (symbol->string (gensym 'slide-subtopic)))) + (options (the-options opt)) + (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)))) + diff --git a/src/guile/skribilo/package/slide/Makefile.am b/src/guile/skribilo/package/slide/Makefile.am index e5fb908..53320fa 100644 --- a/src/guile/skribilo/package/slide/Makefile.am +++ b/src/guile/skribilo/package/slide/Makefile.am @@ -1,4 +1,4 @@ guilemoduledir = $(GUILE_SITE)/skribilo/package/slide -dist_guilemodule_DATA = latex.scm html.scm lout.scm +dist_guilemodule_DATA = base.scm latex.scm html.scm lout.scm ## arch-tag: 56b5fa5c-bb6a-4692-b929-74bdd032431c diff --git a/src/guile/skribilo/package/slide/base.scm b/src/guile/skribilo/package/slide/base.scm new file mode 100644 index 0000000..8c95881 --- /dev/null +++ b/src/guile/skribilo/package/slide/base.scm @@ -0,0 +1,174 @@ +;;; base.scm -- Overhead transparencies, `base' engine. +;;; +;;; 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-module (skribilo package slide base) + :use-module (skribilo utils syntax) + + :use-module (skribilo package slide) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo ast) + :autoload (skribilo output) (output) + :autoload (skribilo package base) (symbol color itemize item) + + :use-module (srfi srfi-1) + + :export (%slide-outline-title %slide-outline-itemize-symbols)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Simple markups. +;;; +(let ((be (find-engine 'base))) + + ;; 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)))) + + +;;; +;;; Helper functions for the default topic/subtopic handling. +;;; + +(define (make-subtopic-list node recurse?-proc make-entry-proc + itemize-symbols) + ;; Make a list of the subtopic of `node'. Go recursive if `recurse?-proc' + ;; returns true. `make-entry-proc' is passed a node and returns an entry + ;; (a markup) for this node. `itemize-symbols' is a (circular) list + ;; containing the symbols to be passed to `itemize'. + (let* ((subtopic? (lambda (n) + (or (is-markup? n 'slide-subtopic) + (is-markup? n 'slide)))) + (subtopic-types (if (is-markup? node 'slide-topic) + '(slide-subtopic slide) + '(slide-topic)))) + (if (subtopic? node) + '() + (apply itemize + `(,@(if (is-markup? (car itemize-symbols) 'symbol) + `(:symbol ,(car itemize-symbols)) + '()) + ,@(map (lambda (t) + (item + (make-entry-proc t) + (if (recurse?-proc t) + (make-subtopic-list t recurse?-proc + make-entry-proc + (cdr itemize-symbols)) + '()))) + (filter (lambda (n) + (and (markup? n) + (member (markup-markup n) + subtopic-types))) + (markup-body node)))))))) + +(define (make-topic-list current-topic recurse? make-entry-proc) + ;; Make a full topic list of the document which contains + ;; `current-topic'. Here, `make-entry-proc' takes a topic node and + ;; the current topic node as its arguments. + (let ((doc (ast-document current-topic))) + (make-subtopic-list doc + (lambda (t) + (and recurse? (eq? t current-topic))) + (lambda (t) + (make-entry-proc t current-topic)) + %slide-outline-itemize-symbols))) + +(define (make-topic-entry topic current-topic) + ;; Produce an entry for `topic'. Colorize it based on the fact + ;; that the current topic is `current-topic' (it may need to be + ;; hightlighted). + (let ((title (markup-option topic :title)) + (current? (eq? topic current-topic))) + (color :fg (if current? "#000000" "#666666") + (apply (if current? bold (lambda (x) x)) + (list (markup-option topic :title)))))) + + +;;; +;;; Default topic/subtopic handling. +;;; + +;; Title for the automatically-generated outline slide. +(define %slide-outline-title "") + +;; Circular list of symbols to be passed to `itemize' in pointers. +(define %slide-outline-itemize-symbols + (let loop ((names '(#t "-" "bullet" "->" "middot"))) + (if (null? names) + '() + (cons (if (string? (car names)) + (symbol (car names)) + (car names)) + (loop (cdr names)))))) + + +(define (make-topic-slide topic engine) + (let ((parent-topic (if (is-markup? topic 'slide-topic) + topic + (find1-up (lambda (n) + (is-markup? n 'slide-topic)) + topic)))) + (output (slide :title %slide-outline-title :toc #f + ;; The mark below is needed for cross-referencing by PDF + ;; bookmarks. + (if (markup-ident topic) (mark (markup-ident topic)) "") + (p (make-topic-list parent-topic #t + make-topic-entry))) + engine))) + + +(markup-writer 'slide-topic (find-engine 'base) + :action (lambda (n e) + (if (markup-option n :outline?) + (make-topic-slide n e)) + + (output (markup-body n) e))) + + +;;; arch-tag: 1187ce0c-3ffc-4248-b68b-a7c77d6598b9 diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm index 58348df..ef2642b 100644 --- a/src/guile/skribilo/package/slide/html.scm +++ b/src/guile/skribilo/package/slide/html.scm @@ -106,6 +106,34 @@ ;;; +;;; Slide topics/subtopics. +;;; + +(markup-writer 'slide-topic (find-engine 'html) + :action (lambda (n e) + (let ((title (markup-option n :title)) + (body (markup-body n))) + (display "\n<h2 class=\"slide-topic:title\">") + (if (markup-ident n) + (printf "<a name=\"~a\"></a>" (markup-ident n))) + (output title e) + (display "</h2> <br>\n") + (display "\n<div class=\"slide-topic:slide-list\">") + (for-each (lambda (s) + (output (markup-option s :title) e) + (display " -- ")) + (filter (lambda (n) + (or (is-markup? n 'slide-subtopic) + (is-markup? n 'slide))) + (markup-body n))) + (display "\n</div> <!-- slide-topic:slide-list -->") + (display "\n<hr><br>\n") + + ;; the slides + (output (markup-body n) e)))) + + +;;; ;;; Initialization. ;;; diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm index 817d0ed..d53cff1 100644 --- a/src/guile/skribilo/package/slide/lout.scm +++ b/src/guile/skribilo/package/slide/lout.scm @@ -131,5 +131,21 @@ (filter (format #f pdfmark command))))))))) + +;;; +;;; Customs for a nice handling of topics/subtopics. +;;; + +(let ((lout (find-engine 'lout))) + (if lout + (begin + (engine-custom-set! lout 'pdf-bookmark-node-pred + (lambda (n e) + (or (is-markup? n 'slide) + (is-markup? n 'slide-topic) + (is-markup? n 'slide-subtopic)))) + (engine-custom-set! lout 'pdf-bookmark-closed-pred + (lambda (n e) #f))))) + ;;; arch-tag: 0c717553-5cbb-46ed-937a-f844b6aeb145 |