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

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 "&nbsp;--&nbsp;"))
+			   (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