From ecafbbd1d3a76cbc36ac94fc84f34e6f76f08cfc Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Thu, 24 Aug 2006 12:55:28 +0000 Subject: slide: Implemented `slide-topic' and `slide-subtopic'. * src/guile/skribilo/package/slide.scm: Don't autoload `(skribilo engine html)'. Moved `when-engine-is-loaded' clauses to the bottom. Move base-engine writers to `slide/base.scm'. (slide-topic): New markup. (slide-subtopic): New markup. * src/guile/skribilo/package/slide/Makefile.am (dist_guilemodule_DATA): Added `base.scm'. * src/guile/skribilo/package/slide/html.scm (slide-topic): New writer. * src/guile/skribilo/package/slide/lout.scm: Added topic/subtopic-related customs. * src/guile/skribilo/package/slide/base.scm: New file. This list might be incomplete or outdated if editing the log message was not invoked from an up-to-date changes buffer! git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-43 --- src/guile/skribilo/package/slide.scm | 97 +++++++-------- src/guile/skribilo/package/slide/Makefile.am | 2 +- src/guile/skribilo/package/slide/base.scm | 174 +++++++++++++++++++++++++++ src/guile/skribilo/package/slide/html.scm | 28 +++++ src/guile/skribilo/package/slide/lout.scm | 16 +++ 5 files changed, 265 insertions(+), 52 deletions(-) create mode 100644 src/guile/skribilo/package/slide/base.scm 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)) ;*---------------------------------------------------------------------*/ @@ -36,23 +35,6 @@ (define %slide-the-slides '()) (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 ... */ ;*---------------------------------------------------------------------*/ @@ -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 +;;; +;;; +;;; 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 @@ -104,6 +104,34 @@ (display "\n"))) + +;;; +;;; 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

") + (if (markup-ident n) + (printf "" (markup-ident n))) + (output title e) + (display "


\n") + (display "\n
") + (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
") + (display "\n

\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 -- cgit v1.2.3