From fc42fe56a57eace2dbdb31574c2e161f0eacf839 Mon Sep 17 00:00:00 2001
From: Ludovic Court`es
Date: Wed, 15 Jun 2005 13:00:39 +0000
Subject: Initial import of Skribe 1.2d.
Initial import of Skribe 1.2d.
git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0
---
skr/web-article.skr | 230 ++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 230 insertions(+)
create mode 100644 skr/web-article.skr
(limited to 'skr/web-article.skr')
diff --git a/skr/web-article.skr b/skr/web-article.skr
new file mode 100644
index 0000000..e33328b
--- /dev/null
+++ b/skr/web-article.skr
@@ -0,0 +1,230 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/web-article.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sat Jan 10 09:09:43 2004 */
+;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */
+;* Copyright : 2004 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* A Skribe style for producing web articles */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* &web-article-load-options ... */
+;*---------------------------------------------------------------------*/
+(define &web-article-load-options (skribe-load-options))
+
+;*---------------------------------------------------------------------*/
+;* web-article-body-width ... */
+;*---------------------------------------------------------------------*/
+(define (web-article-body-width e)
+ (let ((w (engine-custom e 'body-width)))
+ (if (or (number? w) (string? w)) w 98.)))
+
+;*---------------------------------------------------------------------*/
+;* html-document-title-web ... */
+;*---------------------------------------------------------------------*/
+(define (html-document-title-web n e)
+ (let* ((title (markup-body n))
+ (authors (markup-option n 'author))
+ (tbg (engine-custom e 'title-background))
+ (tfg (engine-custom e 'title-foreground))
+ (tfont (engine-custom e 'title-font)))
+ (printf "
\n"
+ (html-width (web-article-body-width e)))
+ (if (string? tbg)
+ (printf "" tbg)
+ (display " | "))
+ (if (string? tfg)
+ (printf "" tfg))
+ (if title
+ (begin
+ (display "")
+ (if (string? tfont)
+ (begin
+ (printf "" tfont)
+ (output title e)
+ (display ""))
+ (begin
+ (printf "")
+ (output title e)
+ (display "")))
+ (display "\n")))
+ (if (not authors)
+ (display "\n")
+ (html-title-authors authors e))
+ (if (string? tfg)
+ (display ""))
+ (display " |
\n")))
+
+;*---------------------------------------------------------------------*/
+;* web-article-css-document-title ... */
+;*---------------------------------------------------------------------*/
+(define (web-article-css-document-title n e)
+ (let* ((title (markup-body n))
+ (authors (markup-option n 'author))
+ (id (markup-ident n)))
+ ;; the title
+ (printf "\n"
+ (string-canonicalize id))
+ (output title e)
+ (display "
\n")
+ ;; the authors
+ (printf "\n"
+ (string-canonicalize id))
+ (for-each (lambda (a) (output a e))
+ (cond
+ ((is-markup? authors 'author)
+ (list authors))
+ ((list? authors)
+ authors)
+ (else
+ '())))
+ (display "
\n")))
+
+;*---------------------------------------------------------------------*/
+;* web-article-css-author ... */
+;*---------------------------------------------------------------------*/
+(define (web-article-css-author n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone))
+ (nfn (engine-custom e 'author-font))
+ (align (markup-option n :align)))
+ (when name
+ (printf ""
+ (string-canonicalize (markup-ident n)))
+ (output name e)
+ (display "\n"))
+ (when title
+ (printf ""
+ (string-canonicalize (markup-ident n)))
+ (output title e)
+ (display "\n"))
+ (when affiliation
+ (printf ""
+ (string-canonicalize (markup-ident n)))
+ (output affiliation e)
+ (display "\n"))
+ (when (pair? address)
+ (printf ""
+ (string-canonicalize (markup-ident n)))
+ (for-each (lambda (a)
+ (output a e)
+ (newline))
+ address)
+ (display "\n"))
+ (when phone
+ (printf ""
+ (string-canonicalize (markup-ident n)))
+ (output phone e)
+ (display "\n"))
+ (when email
+ (printf ""
+ (string-canonicalize (markup-ident n)))
+ (output email e)
+ (display "\n"))
+ (when url
+ (printf ""
+ (string-canonicalize (markup-ident n)))
+ (output url e)
+ (display "\n"))))
+
+;*---------------------------------------------------------------------*/
+;* HTML settings */
+;*---------------------------------------------------------------------*/
+(define (web-article-modern-setup he)
+ (let ((sec (markup-writer-get 'section he))
+ (ft (markup-writer-get '&html-footnotes he)))
+ ;; &html-document-title
+ (markup-writer '&html-document-title he
+ :action html-document-title-web)
+ ;; section
+ (markup-writer 'section he
+ :options 'all
+ :before "
"
+ :action (lambda (n e)
+ (let ((e1 (make-engine 'html-web :delegate e))
+ (bg (engine-custom he 'section-background)))
+ (markup-writer 'section e1
+ :options 'all
+ :action (lambda (n e2) (output n e sec)))
+ (skribe-eval
+ (center (color :width (web-article-body-width e)
+ :margin 5 :bg bg n))
+ e1))))
+ ;; &html-footnotes
+ (markup-writer '&html-footnotes he
+ :options 'all
+ :before "
"
+ :action (lambda (n e)
+ (let ((e1 (make-engine 'html-web :delegate e))
+ (bg (engine-custom he 'section-background))
+ (fg (engine-custom he 'subsection-title-foreground)))
+ (markup-writer '&html-footnotes e1
+ :options 'all
+ :action (lambda (n e2)
+ (invoke (writer-action ft) n e)))
+ (skribe-eval
+ (center (color :width (web-article-body-width e)
+ :margin 5 :bg bg :fg fg n))
+ e1))))))
+
+;*---------------------------------------------------------------------*/
+;* web-article-css-setup ... */
+;*---------------------------------------------------------------------*/
+(define (web-article-css-setup he)
+ (let ((sec (markup-writer-get 'section he))
+ (ft (markup-writer-get '&html-footnotes he)))
+ ;; &html-document-title
+ (markup-writer '&html-document-title he
+ :before (lambda (n e)
+ (printf "\n"
+ (string-canonicalize (markup-ident n))))
+ :action web-article-css-document-title
+ :after "
\n")
+ ;; author
+ (markup-writer 'author he
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :before (lambda (n e)
+ (printf "\n"
+ (string-canonicalize (markup-ident n))))
+ :action web-article-css-author
+ :after ""
+ (string-canonicalize (markup-ident n))))
+ :action (lambda (n e) (output n e sec))
+ :after "\n")
+ ;; &html-footnotes
+ (markup-writer '&html-footnotes he
+ :options 'all
+ :before (lambda (n e)
+ (printf "\n")))
+
+;*---------------------------------------------------------------------*/
+;* Setup ... */
+;*---------------------------------------------------------------------*/
+(let* ((opt &web-article-load-options)
+ (p (memq :style opt))
+ (css (memq :css opt))
+ (he (find-engine 'html)))
+ (cond
+ ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css))
+ (web-article-css-setup he))
+ ((and (pair? css) (pair? (cdr css)) (string? (cadr css)))
+ (engine-custom-set! he 'css (cadr css))
+ (web-article-css-setup he))
+ (else
+ (web-article-modern-setup he))))
--
cgit v1.2.3