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 --- skribe/skr/html4.skr | 165 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100644 skribe/skr/html4.skr (limited to 'skribe/skr/html4.skr') diff --git a/skribe/skr/html4.skr b/skribe/skr/html4.skr new file mode 100644 index 0000000..acb7068 --- /dev/null +++ b/skribe/skr/html4.skr @@ -0,0 +1,165 @@ +;;;; +;;;; html4.skr -- HTML 4.01 Engine +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 18-Feb-2004 11:58 (eg) +;;;; Last file update: 26-Feb-2004 21:09 (eg) +;;;; + +(define (find-children node) + (define (flat l) + (cond + ((null? l) l) + ((pair? l) (append (flat (car l)) + (flat (cdr l)))) + (else (list l)))) + + (if (markup? node) + (flat (markup-body node)) + node)) + +;;; ====================================================================== + +(let ((le (find-engine 'html))) + ;;---------------------------------------------------------------------- + ;; Customizations + ;;---------------------------------------------------------------------- + (engine-custom-set! le 'html-variant "html4") + (engine-custom-set! le 'html4-logo "http://www.w3.org/Icons/valid-html401") + (engine-custom-set! le 'html4-validator "http://validator.w3.org/check/referer") + + ;;---------------------------------------------------------------------- + ;; &html-html ... + ;;---------------------------------------------------------------------- + (markup-writer '&html-html le + :before " +\n" + :after "") + + ;;---------------------------------------------------------------------- + ;; &html-ending + ;;---------------------------------------------------------------------- + (let* ((img (engine-custom le 'html4-logo)) + (url (engine-custom le 'html4-validator)) + (bottom (list (hrule) + (table :width 100. + (tr + (td :align 'left + (font :size -1 [ + This ,(sc "Html") page has been produced by + ,(ref :url (skribe-url) :text "Skribe"). + ,(linebreak) + Last update ,(it (date)).])) + (td :align 'right :valign 'top + (ref :url url + :text (image :url img :width 88 :height 31)))))))) + (markup-writer '&html-ending le + :before "
" + :action (lambda (n e) + (let ((body (markup-body n))) + (if body + (output body #t) + (skribe-eval bottom e)))) + :after "
\n")) + + ;;---------------------------------------------------------------------- + ;; color ... + ;;---------------------------------------------------------------------- + (markup-writer 'color le + :options '(:bg :fg :width :margin) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (w (markup-option n :width)) + (bg (markup-option n :bg)) + (fg (markup-option n :fg))) + (when bg + (display "\n") + (display "\n
")) + (when fg + (display "")))) + :after (lambda (n e) + (when (markup-option n :fg) + (display "")) + (when (markup-option n :bg) + (display "
")))) + + ;;---------------------------------------------------------------------- + ;; font ... + ;;---------------------------------------------------------------------- + (markup-writer 'font le + :options '(:size :face) + :before (lambda (n e) + (let ((face (markup-option n :face)) + (size (let ((sz (markup-option n :size))) + (cond + ((or (unspecified? sz) (not sz)) + #f) + ((and (number? sz) (or (inexact? sz) (negative? sz))) + (format "~a%" + (+ 100 + (* 20 (inexact->exact (truncate sz)))))) + ((number? sz) + sz) + (else + (skribe-error 'font + (format "Illegal font size ~s" sz) + n)))))) + (display ""))) + :after "") + + ;;---------------------------------------------------------------------- + ;; paragraph ... + ;;---------------------------------------------------------------------- + (copy-markup-writer 'paragraph le + :validate (lambda (n e) + (let ((pred (lambda (x) + (and (container? x) + (not (memq (markup-markup x) '(font color))))))) + (not (any pred (find-children n)))))) + + ;;---------------------------------------------------------------------- + ;; roman ... + ;;---------------------------------------------------------------------- + (markup-writer 'roman le + :before "" + :after "") + + ;;---------------------------------------------------------------------- + ;; table ... + ;;---------------------------------------------------------------------- + (let ((old-writer (markup-writer-get 'table le))) + (copy-markup-writer 'table le + :validate (lambda (n e) + (not (null? (markup-body n)))))) +) -- cgit v1.2.3