diff options
Diffstat (limited to 'src/guile/skribilo/package/slide/html.scm')
| -rw-r--r-- | src/guile/skribilo/package/slide/html.scm | 127 |
1 files changed, 90 insertions, 37 deletions
diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm index d47ef82..9a5148d 100644 --- a/src/guile/skribilo/package/slide/html.scm +++ b/src/guile/skribilo/package/slide/html.scm @@ -18,43 +18,75 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo package slide html) - :use-module (skribilo package slide)) +(define-module (skribilo package slide html) + :use-module (skribilo utils syntax) + :use-module (skribilo ast) + :use-module (skribilo engine) + :use-module (skribilo writer) + :autoload (skribilo resolve) (resolve!) + :autoload (skribilo output) (output) + :autoload (skribilo evaluator) (evaluate-document) + :autoload (skribilo engine html) (html-width html-title-authors) + :use-module (skribilo package slide) + :use-module ((skribilo package base) :select (ref))) + + +(fluid-set! current-reader %skribilo-module-reader) + + + (define-public (%slide-html-initialize!) - (let ((he (find-engine 'html))) - (skribe-message "HTML slides setup...\n") + (let ((he (lookup-engine-class 'html))) + (display "HTML slides setup...\n" (current-error-port)) + ;; &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")) + (display "<br>\n") + (format #t "<a name=\"~a\">" (markup-ident 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 #f "~a / ~a -- " nb - (slide-number))) - t))) - (tr (td (hrule))) - (tr (td :width 100. :align 'left - (markup-body n)))) - (linebreak))) - e))) + (t (markup-option n :title)) + (class (markup-class n))) + (if class + (let ((title-class (string-append class "-title"))) + ;; When a class is specified, let the user play + ;; with CSS. + (format #t "\n<div class=\"~a\">" class) + (format #t "<div class=\"~a\">" title-class) + (format #t "~a / ~a -- " nb (slide-number)) + (output t e) + (display "</div>\n") + (output (markup-body n) e) + (display "\n</div>\n")) + ;; When no class is specified, do HTML tricks. + (evaluate-document + (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 #f "~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>"))))) @@ -76,23 +108,23 @@ (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>" + (format #t "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribilo-title\"><tbody>\n<tr>" (html-width (slide-body-width e))) (if (string? tbg) - (printf "<td bgcolor=\"~a\">" tbg) + (format #t "<td bgcolor=\"~a\">" tbg) (display "<td>")) (if (string? tfg) - (printf "<font color=\"~a\">" tfg)) + (format #t "<font color=\"~a\">" tfg)) (if title (begin (display "<center>") (if (string? tfont) (begin - (printf "<font ~a><strong>" tfont) + (format #t "<font ~a><strong>" tfont) (output title e) (display "</strong></font>")) (begin - (printf "<div class=\"skribetitle\"><strong><big><big><big>") + (display "<div class=\"skribilo-title\"><strong><big><big><big>") (output title e) (display "</big></big></big></strong</div>"))) (display "</center>\n"))) @@ -109,26 +141,47 @@ ;;; Slide topics/subtopics. ;;; -(markup-writer 'slide-topic (find-engine 'html) +(markup-writer 'slide-topic (lookup-engine-class 'html) :options '(:title :outline? :class :ident) :action (lambda (n e) (let ((title (markup-option n :title)) - (body (markup-body n))) - (display "\n<h2 class=\"slide-topic:title\">") + (body (markup-body n)) + (class (markup-class n))) + ;; top-level class + (if class (format #t "\n<div class=\"~a\">" class)) + + ;; the title + (if class + (format #t "\n<div class=\"~a-title\">" class) + (display "\n<h2 class=\"slide-topic:title\">")) (if (markup-ident n) - (printf "<a name=\"~a\"></a>" (markup-ident n))) + (format #t "<a name=\"~a\"></a>" (markup-ident n))) (output title e) - (display "</h2> <br>\n") - (display "\n<div class=\"slide-topic:slide-list\">") + (if class + (display "</div>\n") + (display "</h2> <br>\n")) + + ;; pointers to the slides + (if class + (format #t "\n<div class=\"~a-slide-list\">" + class) + (display "\n<div class=\"slide-topic:slide-list\">")) (for-each (lambda (s) - (output (markup-option s :title) e) - (display " -- ")) + (let* ((title (markup-option s :title)) + (ident (markup-ident s)) + (sref (ref :text title :ident ident)) + (sref* (resolve! sref e `((parent ,n))))) + (output sref* 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") + + (if class + (display "\n</div> <!-- slide-topic -->\n") + (display "\n<hr><br>\n")) ;; the slides (output (markup-body n) e)))) |