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 <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
@@ -104,6 +104,34 @@
(display "</td></tr></tbody></table></center>\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<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
--
cgit v1.2.3