File dbtohtml.dsl of Package docbook-dsssl-stylesheets

Overview Repositories Revisions Requests Users Attributes Meta

File dbtohtml.dsl of Package docbook-dsssl-stylesheets (Revision 1abe1e9020cb4b9f512177047b97176d)

Currently displaying revision 1abe1e9020cb4b9f512177047b97176d , Show latest

<!doctype style-sheet PUBLIC "-//James Clark//DTD DSSSL Style Sheet//EN">
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; dbtohtml.dsl - DSSSL style sheet for DocBook to HTML conversion (jadeware)
;
; Author          : Mark Burton (markb@ordern.com)
; Created On      : Fri Jun 13 18:21:14 1997
; Last Modified By: Mark Burton
; Last Modified On: Sat Nov 21 22:04:53 1998
;
; $Id: dbtohtml.dsl,v 1.23 1998/11/21 22:11:14 markb Exp $
;
; Usage:
;
; jade -d dbtohtml.dsl -t sgml yourdoc.sgm
;
; Additional command line options:
;
; -V %no-split-output%  sends all the output to one file
; -V %no-make-index%    disables index creation
; -V %no-make-toc%      disables TOC creation
; -V %no-shade-screen%  disables grey background to SCREEN regions
; -V %show-comments%    includes contents of COMMENT regions
;
; See below for more variables that can be set.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Contributors

; Mark Eichin   (eichin@cygnus.com)
; Jason Molenda (crash@cygnus.co.jp)
; Tony Graham   (tgraham@mulberrytech.com)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Parameterisation

; This style sheet can easily be parameterised by the use of a driver.
; Here is a simple example that sets the output file basename and directory.
; If the driver is foo.dsl, use: jade -d foo.dsl -t sgml yourdoc.sgm

<!--

<!doctype style-sheet PUBLIC "-//James Clark//DTD DSSSL Style Sheet//EN" [
<!ENTITY dbtohtml.dsl SYSTEM "dbtohtml.dsl" CDATA DSSSL >
]>

(define %output-basename% "foo")
(define %output-directory% "foodir")

</style-specification>

<external-specification id="dbtohtml" document="dbtohtml.dsl">

-->

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; declare non-standard functions

(declare-flow-object-class element
  "UNREGISTERED::James Clark//Flow Object Class::element")
(declare-flow-object-class empty-element
  "UNREGISTERED::James Clark//Flow Object Class::empty-element")
(declare-flow-object-class document-type
  "UNREGISTERED::James Clark//Flow Object Class::document-type")
(declare-flow-object-class processing-instruction
  "UNREGISTERED::James Clark//Flow Object Class::processing-instruction")
(declare-flow-object-class entity
  "UNREGISTERED::James Clark//Flow Object Class::entity")
(declare-flow-object-class entity-ref
  "UNREGISTERED::James Clark//Flow Object Class::entity-ref")
(declare-flow-object-class formatting-instruction
  "UNREGISTERED::James Clark//Flow Object Class::formatting-instruction")

(declare-characteristic preserve-sdata?
  "UNREGISTERED::James Clark//Characteristic::preserve-sdata?" #f)

(define all-element-number
  (external-procedure "UNREGISTERED::James Clark//Procedure::all-element-number"))

(define debug
  (external-procedure "UNREGISTERED::James Clark//Procedure::debug"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; variables

(define %no-split-output% #f)		; if #t puts all output in one file
(define %no-split-refentries% #f)	; if #t don't put refentries
					; in separate files
(define %no-make-toc% #f)		; if #t disables TOC creation
(define %no-make-index% #f)		; if #t disables index creation
(define %no-shade-screen% #f)		; if #t disables grey
					; background to SCREEN regions
(define %show-comments% #f)		; if #t includes contents of
					; COMMENT regions
(define %shade-width% "100%")		; width string or #f
(define %email-element% "TT")		; font changing element or #f

(define %lineannotation-color% "green")	; colour or #f (ignored if
					; %stylesheet-name% is not #f)

(define %warning-color% "red")		; colour or #f
(define %important-color% #f)		; colour or #f
(define %caution-color% #f)		; colour or #f
(define %tip-color% #f)			; colour or #f
(define %note-color% #f)		; colour or #f
(define %example-color% #f)		; colour or #f

(define %display-dpi% 100)		; for converting lengths into pixels

(define %centre-figures% #t)		; whether figures should be centred

(define %default-graphic-format% "gif")
(define %graphic-directory% #f)		; name of directory containing
					; graphics or #f

(define %html-public-id% "-//W3C//DTD HTML 4.0//EN")

(define %stylesheet-name% #f)		; name of css style-sheet to
					; be used or #f
(define %have-javascript% #f)		; true if browser groks JavaScript
(define %make-nav-links% #f)		; true if pages should have
					; navigation links at their
					; top and bottom
(define %body-bgcolor% "white")		; document background colour
					; (ignored if %stylesheet-name% is
					; not #f
(define %output-directory% ".")		; where to write generated HTML
(define %output-basename% "DBTOHTML")	; generated filenames are
					; based on this
(define %output-suffix% ".html")	; generated filename suffix
(define %newline% "\U-000D")		; there must be an easier way
					; to specify \n

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; top-level sections

(element BOOK
  (if %no-split-output%			; everything goes in one file
      (make-file (string-append %output-basename% %output-suffix%)
		 (make sequence
		   (process-children)
		   (cond ((not %no-make-index%)
			  (make sequence
			    (make-fat-rule)
			    (make-index)))
			 (#t (empty-sosofo))))
		 (current-node)
		 (node-list)
		 (node-list))
      (make sequence			; split output into separate files
	(let* ((content (make sequence
			  (process-first-descendant "TITLE")
			  (process-first-descendant "BOOKINFO")))
	       (children (children (current-node)))
	       (linkable-children (node-list (select-elements children "PREFACE")
					     (select-elements children "ARTICLE")
					     (select-elements children "CHAPTER")
					     (select-elements children "APPENDIX"))))
	  (make-file (string-append %output-basename% %output-suffix%)
		     (if %stylesheet-name%
			 (make element
			   gi: "DIV"
			      attributes: '(("class" "book"))
			      content)
			 content)
		     (current-node)
		     (node-list-last linkable-children)
		     (node-list-first linkable-children)))
	(process-matching-children "PREFACE"
				   "ARTICLE"
				   "CHAPTER"
				   "APPENDIX"
				   "BIBLIOGRAPHY"
				   "GLOSSARY"
				   "ARTHEADER")
	(if %no-make-index%
	    (empty-sosofo)
	    (make-file (index-file-name)
		       (make sequence
			 (make-nav-links (current-node))
			 (make-index)
			 (make-nav-links (current-node)))
		       (current-node)
		       (node-list)
		       (node-list))))))

(define (make-file file-name content top-node preceding-node following-node)
  (make entity
    system-id: (string-append %output-directory% "/" file-name)
    (make sequence
      (make document-type
	name: "HTML"
	public-id: %html-public-id%)
      (make element
	gi: "HTML" 
	(make sequence
	  (make element
	    gi: "HEAD"
	    (make sequence
	      (make element
		gi: "TITLE"
		(with-mode extract-title-text
		  (process-first-descendant "TITLE")))
	      (if %stylesheet-name%
		  (make empty-element
		    gi: "LINK"
		    attributes: (list (list "rel" "stylesheet")
				      (list "type" "text/css")
				      (list "href" %stylesheet-name%)))
		  (empty-sosofo))
	      (if %have-javascript%
		  (make element
		    gi: "SCRIPT"
		    attributes: '(("type" "text/javascript"))
		    (make sequence
		      (make formatting-instruction
			data: (string-append %newline% "<" "!--" %newline%))
		      (literal "var toppage='"
			       (link-file-name top-node)
			       "';" %newline%
			       "var nextpage='"
			       (if (node-list-empty? following-node)
				   (link-file-name top-node)
				   (link-file-name following-node))
			       "';" %newline%
			       "var prevpage='"
			       (if (node-list-empty? preceding-node)
				   (link-file-name top-node)
				   (link-file-name preceding-node))
			       "';" %newline%
			       (if %no-make-index%
				   ""
				   (string-append "var indexpage='"
						  (index-file-name)
						  "';" %newline%))
			       )
		      (make formatting-instruction
			data: (string-append "// -->" %newline%))))
		  (empty-sosofo))))
	  (make element
	    gi: "BODY"
	    attributes: (if %stylesheet-name%
			    (list)
			    (list (list "bgcolor" %body-bgcolor%)))
	    (make sequence
	      (if %stylesheet-name%
		  (make element
		    gi: "DIV"
		    (make-anchor))
		  (make-anchor))
	      content
	      (make-footer))))))))
			 
(define (make-footer)
  (let ((copyright (select-elements (descendants (book-node))
				    '("BOOKINFO" "COPYRIGHT"))))
    (cond ((node-list-empty? copyright) (empty-sosofo))
	  (#t (make sequence
		(make-fat-rule)
		(process-node-list copyright))))))

(define (node-list-last nl)
  (node-list-ref nl (- (node-list-length nl) 1)))

(define (filtered-preceding-node)
  (let* ((preceding-node (node-list-last (preced (current-node))))
	 (acceptable-neighbours '("CHAPTER" "APPENDIX" "GLOSSARY" "REFENTRY")))
    (if (member (gi preceding-node) acceptable-neighbours)
	preceding-node
	(node-list))))

(define (filtered-following-node)
  (let* ((following-node (node-list-first (follow (current-node))))
	 (acceptable-neighbours '("CHAPTER" "APPENDIX" "GLOSSARY" "REFENTRY")))
    (if (member (gi following-node) acceptable-neighbours)
	following-node
	(node-list))))

(define (make-nav-links up-node)
  (if %make-nav-links%
      (let ((gubbins
	     (let ((filtered-preceding-node (filtered-preceding-node))
		   (filtered-following-node (filtered-following-node)))
	       (make sequence
		 (make empty-element
		   gi: "P")
		 (make element
		   gi: "A"
		   attributes: (list (list "href" (link-file-name up-node)))
		   (literal "Up"))
		 (literal " ")
		 (if (node-list-empty? filtered-following-node)
		     (empty-sosofo)
		     (make element
		       gi: "A"
		       attributes: (list (list "href"
					       (link-file-name filtered-following-node)))
		       (literal "Forward")))
		 (literal " ")
		 (if (node-list-empty? filtered-preceding-node)
		     (empty-sosofo)
		     (make element
		       gi: "A"
		       attributes: (list (list "href"
					       (link-file-name filtered-preceding-node)))
		       (literal "Back")))
		 (make empty-element
		   gi: "P")))))
	(if %stylesheet-name%
	    (make element
	      gi: "DIV"
	      attributes: '(("class" "navlinks"))
	      gubbins)
	    gubbins))
      (empty-sosofo)))

(define (make-major-div)
  (cond (%no-split-output%
	 (make sequence
	   (make-anchor)
	   (make-fat-rule)
	   (process-children)))
	(#t
	 (make-file (link-file-name (current-node))
		    (make sequence
		      (make-nav-links (book-node))
		      (if %stylesheet-name%
			  (make element
			    gi: "DIV"
			    attributes: '(("class" "chapter"))
			    (process-children))
			  (process-children))
		      (make-nav-links (book-node)))
		    (book-node)
		    (filtered-preceding-node)
		    (filtered-following-node)))))

(element ARTICLE (make-major-div))

(element PREFACE (make-major-div))

(element CHAPTER (make-major-div))

(element APPENDIX (make-major-div))

(element BEGINPAGE (make-thin-rule))

(element BIBLIOGRAPHY (make-major-div))

(element BOOKBIBLIO (process-children))

(element BIBLIODIV (process-children))

(element GLOSSARY (make-major-div))

; (element GLOSSDIV (make-major-div))

(element ARTHEADER (process-children))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; sections

(element SECT1
  (make sequence
    (make empty-element
      gi: "P")
    (make-anchor)
    (process-children)))

(element SECT2
  (make sequence
    (make-anchor)
    (process-children)))

(element SECT3
  (make sequence
    (make-anchor)
    (process-children)))

(element SECT4
  (make sequence
    (make-anchor)
    (process-children)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; reference pages

(element REFENTRY 
  (if (or %no-split-output% %no-split-refentries%)
      (make sequence
	(make-anchor)
	(make-fat-rule)
	(process-children))
      (let ((filename (link-file-name (current-node)))
	    (title-text (with-mode make-toc-links (process-first-descendant "REFMETA"))))
	(make sequence
	  (make-file filename
		     (make sequence
		       (make-nav-links (parent (current-node)))
		       (if %stylesheet-name%
			   (make element
			     gi: "DIV"
			     attributes: '(("class" "refentry"))
			     (process-children))
			   (process-children))
		       (make-nav-links (parent (current-node))))
		     (parent (current-node))
		     (filtered-preceding-node)
		     (filtered-following-node))
	  (make empty-element
	    gi: "P")
	  (make element
	    gi: "A"
	    attributes: (list (list "href" filename))
	    title-text)))))

(define (refmeta) 
  (make sequence
    (process-matching-children "REFENTRYTITLE")
    (literal "(")
    (process-matching-children "MANVOLNUM")
    (literal ")")))

(define (refentrytitle)
  (process-children-trim))
(define (manvolnum)
  (process-children-trim))

(mode make-toc-links
  (element REFMETA (refmeta))
  (element REFENTRYTITLE (refentrytitle))
  (element MANVOLNUM (manvolnum)))

(element REFMETA
  (if %stylesheet-name%
      (make element
	gi: "DIV"
	attributes: '(("style" "text-align: right"))
	(refmeta))
      (refmeta)))

(element REFENTRYTITLE (refentrytitle))
(element MANVOLNUM (manvolnum))

(element REFNAMEDIV
  (make sequence
    (make element
      gi: "H2"
      (literal "NAME"))
    (process-matching-children "REFNAME")
    (literal " - ")
    (process-matching-children "REFPURPOSE")))

(element REFNAME (process-children-trim))
(element REFPURPOSE (process-children-trim))

(element REFSYNOPSISDIV (process-children))
(element REFSECT1 (process-children))
(element REFSECT2 (process-children))
(element REFSECT3 (process-children))
(element REFSECT4 (process-children))

(element CMDSYNOPSIS
  (make element
    gi: "TT"))

(element ARG
  (let ((optional (equal? (attribute-string "CHOICE") "OPT"))
	(repeat (equal? (attribute-string "REP") "REPEAT"))
	(content (process-children-trim)))
    (if optional
	(make sequence
	  (literal " [ ")
	  content
	  (if repeat
	      (literal " ... ")
	      (empty-sosofo))
	  (literal " ] "))
	(make sequence
	  (literal " ")
	  content
	  (if repeat
	      (literal " ... ")
	      (empty-sosofo))
	  (literal " ")))))

(element FUNCSYNOPSIS
  (let ((gubbins (make sequence
		   (process-matching-children "FUNCSYNOPSISINFO")
		   (process-matching-children "FUNCDEF" "PARAMDEF"))))
    (if %stylesheet-name%
	gubbins
	(make element
	  gi: "TT"
	  gubbins))))

(element FUNCSYNOPSISINFO
  (make element
    gi: "PRE"
    attributes: '(("class" "funcsynopsisinfo"))))

(element FUNCDEF
  (make sequence
    (make empty-element
      gi: "TABLE")
    (make empty-element
      gi: "TR"
      attributes: (list '("valign" "top")))
    (make empty-element
      gi: "TD")
    (make empty-element
      gi: "PRE"
      attributes: '(("class" "plain")))
    (make empty-element
      gi: "TT")
    (process-children-trim)))

(element PARAMDEF
  (let ((head (if (equal? (gi (node-list-last (preced (current-node))))
			  "PARAMDEF")
		  (literal ", ")
		  (make sequence
		    (literal "(")
		    (make empty-element
		      gi: "/TT")
		    (make empty-element
		      gi: "/PRE")
		    (make empty-element
		      gi: "TD")
		    (make empty-element
		      gi: "TT"))))
	(tail (if (equal? (gi (node-list-first (follow (current-node))))
			      "PARAMDEF")
		  (empty-sosofo)
		  (make sequence
		    (literal " );")
		    (make empty-element
		      gi: "/TT")
		    (make empty-element
		      gi: "/TABLE")))))
    (make sequence
      head
      (process-children-trim)
      tail)))

(element CITEREFENTRY
  (make sequence
    (process-matching-children "REFENTRYTITLE")
    (literal "(")
    (process-matching-children "MANVOLNUM")
    (literal ")")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; titles

(mode extract-title-text
  (element (TITLE)
    (process-children)))

(element (BOOK TITLE)
  (let ((content (make element
		   gi: "H1"
		   attributes: '(("class" "book"))
		   (process-children-trim))))
    (if %stylesheet-name%
	content
	(make element
	  gi: "CENTER"
	  content))))

(element (CHAPTER TITLE)
  (make element
    gi: "H1"
    attributes: '(("class" "chapter"))
    (make sequence
      (literal (chap-app-head-label "Chapter"))
      (process-children-trim))))

(element (APPENDIX TITLE)
  (make element
    gi: "H1"
    attributes: '(("class" "appendix"))
    (make sequence
      (literal (chap-app-head-label "Appendix"))
      (process-children-trim))))

(element (BIBLIOGRAPHY TITLE)
  (make element
    gi: "H1"
    attributes: '(("class" "bibliography"))
    (make sequence
      (literal (chap-app-head-label "Bibliography"))
      (process-children-trim))))

(element (BOOKBIBLIO TITLE)
  (make element
    gi: "H2"
    attributes: '(("class" "bookbiblio"))
    (make sequence
;;;      (literal (chap-app-head-label "Bibliography"))
      (process-children-trim))))

(element (BIBLIODIV TITLE)
  (make element
    gi: "H2"
    attributes: '(("class" "bibliodiv"))
    (make sequence
      (process-children-trim))))

(element (GLOSSARY TITLE)
  (make element
    gi: "H1"
    attributes: '(("class" "glossary"))
    (make sequence
      (literal "Glossary")
;      (process-children-trim)
      )))

(element (GLOSSDIV TITLE)
  (make element
    gi: "H2"
    attributes: '(("class" "glossdiv"))
    (process-children-trim)))

(element (ARTHEADER TITLE)
  (let ((content (make element
		   gi: "H1"
		   attributes: '(("class" "artheader"))
		   (process-children-trim))))
    (if %stylesheet-name%
	content
	(make element
	  gi: "CENTER"
	  content))))
 
(element (SECT1 TITLE)
  (make element
    gi: "H2"
    attributes: '(("class" "sect1"))))

(element (SECT2 TITLE)
  (make element
    gi: "H3"
    attributes: '(("class" "sect2"))))

(element (SECT3 TITLE)
  (make element
    gi: "H4"
    attributes: '(("class" "sect3"))))

(element (SECT4 TITLE)
  (make element
    gi: "H5"
    attributes: '(("class" "sect1"))))

(element (FORMALPARA TITLE)
  (make element
    gi: "H4"
    attributes: '(("class" "formalpara"))))

(element (SIDEBAR TITLE)
  (make element
    gi: "H2"
    attributes: '(("class" "sidebar"))))

(element (REFSYNOPSISDIV TITLE)
  (make element
    gi: "H2"
    attributes: '(("class" "refsynopsisdiv"))))

(element (REFSECT1 TITLE)
  (make element
    gi: "H2"
    attributes: '(("class" "refsect1"))))

(element (REFSECT2 TITLE)
  (make element
    gi: "H3"
    attributes: '(("class" "refsect2"))))

(element (REFSECT3 TITLE)
  (make element
    gi: "H4"
    attributes: '(("class" "refsect1"))))

(element (REFSECT4 TITLE)
  (make element
    gi: "H5"
    attributes: '(("class" "sect4"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; font changers

(element LINEANNOTATION
  (cond (%stylesheet-name%
	 (make element
	   gi: "SPAN"
	   attributes: '(("class" "lineannotation"))
	   (process-children-trim)))
	(%lineannotation-color%
	 (make element
	   gi: "FONT"
	   attributes: (list (list "color" %lineannotation-color%))
	   (process-children-trim)))
	(#t (process-children-trim))))

(element EMPHASIS
  (make element gi: "I"))

(element TYPE
  (make element gi: "B" 
	(make element gi: "TT")))

(element REPLACEABLE
  (make element gi: "I"
	(make element gi: "B" 
	      (make element gi: "TT"))))

(element TOKEN 
  (if %stylesheet-name%
      (make element
	gi: "SPAN"
	attributes: '(("class" "token"))
	(process-children-trim))
      (process-children-trim)))

(element PARAMETER (make element gi: "I"))

(element FIRSTTERM (make element gi: "I"))

(element APPLICATION (make element gi: "TT"))

(element SYSTEMITEM (make element gi: "TT"))

(element FILENAME (make element gi: "TT"))

(element LITERAL (make element gi: "TT"))

(element ENVAR (make element gi: "TT"))

(element SUBSCRIPT (make element gi: "SUB"))

(element SUPERSCRIPT (make element gi: "SUP"))

(element CITETITLE (make element gi: "I"))

(element GUIBUTTON   (make element gi: "I"))
(element GUIMENU     (make element gi: "I"))
(element GUIMENUITEM (make element gi: "I"))
(element GUILABEL    (make element gi: "I"))

(element STRUCTNAME  (make element gi: "TT"))
(element STRUCTFIELD (make element gi: "TT"))

(element COMMAND (make element gi: "TT"))

(element OPTION (make element gi: "TT"))

(element USERINPUT (make element gi: "TT"))

(element COMPUTEROUTPUT (make element gi: "TT"))

(element PROMPT (make element gi: "TT"))

(element PRODUCTNAME (make element gi: "I"))

(element SGMLTAG (make element gi: "TT"))

(element (FUNCDEF FUNCTION)
  (make element
    gi: "B"
    (make element
      gi: "TT")))
(element FUNCTION (make element gi: "TT"))

(element SYMBOL (make element gi: "TT"))
(element LITERALLAYOUT
  (make element
    gi: "PRE"
    attributes: '(("class" "literallayout"))))

(element FOREIGNPHRASE (make element gi: "I"))

(element ABBREV (process-children-trim))

(element EMAIL
  (if %email-element%
      (make element
	gi: %email-element%
	(process-children-trim))
      (process-children-trim)))

(element QUOTE
  (make sequence
    (make entity-ref
      name: "quot")
    (process-children-trim)
    (make entity-ref
      name: "quot")))

(element ADDRESS
  (make element
    gi: "ADDRESS"
    (process-children-trim)))

(element (ADDRESS CITY)
  (make sequence
    (make empty-element 
      gi: "BR")
    (process-children-trim)))

(element (ADDRESS COUNTRY)
  (make sequence
    (make empty-element 
      gi: "BR")
    (process-children-trim)))

(element (ADDRESS EMAIL)
  (make sequence
    (make empty-element
      gi: "BR")
    (if %email-element%
	(make element
	  gi: %email-element%
	  (process-children-trim))
	(process-children-trim))))

(element (ADDRESS FAX)
  (make sequence
    (make empty-element 
      gi: "BR")
    (process-children-trim)))

(element (ADDRESS OTHERADDR)
  (make sequence
    (make empty-element 
      gi: "BR")
    (process-children-trim)))

(element (ADDRESS POB)
  (make sequence
    (make empty-element 
      gi: "BR")
    (process-children-trim)))

(element (ADDRESS PHONE)
  (make sequence
    (make empty-element 
      gi: "BR")
    (process-children-trim)))

(element (ADDRESS POSTCODE)
  (process-children-trim))

(element (ADDRESS STATE)
  (process-children-trim))

(element (ADDRESS STREET)
  (make sequence
    (make empty-element 
      gi: "BR")
    (process-children-trim)))

(element PROGRAMLISTING
  (make element
    gi: "PRE"
    attributes: '(("class" "programlisting"))))

(element SECT2INFO
  (empty-sosofo))

(element SYNOPSIS
  (make element
    gi: "PRE"
    attributes: '(("class" "synopsis"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; paragraph like things

(element CAUTION
  (if %caution-color%
      (make-color-para %caution-color%)
      (make-special-para)))

(element IMPORTANT
  (if %important-color%
      (make-color-para %important-color%)
      (make-special-para)))

(element WARNING 
  (if %warning-color%
      (make-color-para %warning-color%)
      (make-special-para)))

(element NOTE
  (if %note-color%
      (make-color-para %note-color%)
      (make-special-para)))

(element TIP
  (if %tip-color%
      (make-color-para %tip-color%)
      (make-special-para)))

(element EXAMPLE
  (if %example-color%
      (make-color-para %example-color%)
      (make-special-para)))

(element COMMENT
  (if %show-comments%
      (make-color-para "red")
      (empty-sosofo)))

(element PARA
  (make sequence
    (make empty-element
      gi: "P")
    (make-anchor)
    (with-mode footnote-ref
      (process-children))
    (with-mode footnote-def
      (process-matching-children "FOOTNOTE"))))

(element BLOCKQUOTE (make element gi: "BLOCKQUOTE"))

(element SCREEN
  (let ((gubbins (make element
		   gi: "PRE"
		   attributes: '(("class" "screen"))
		   (process-children))))
    (make sequence
      (make empty-element
	gi: "P")
      (if (or %stylesheet-name% %no-shade-screen%)
	  gubbins
	  (make element
	    gi: "TABLE"
	    attributes: (append (list '("border" "0")
				      '("bgcolor" "#E0E0E0"))
				(if %shade-width%
				    (list (list "width" %shade-width%))
				    '()))
	    (make element
	      gi: "TR"
	      (make element
		gi: "TD"
		gubbins)))))))

(element FORMALPARA (process-children))

(element PHRASE (maybe-bold-children))

(mode footnote-ref
  (element FOOTNOTE
    (let ((num (format-number (element-number (current-node)) "1")))
      (make element
	gi: "SUP"
	attributes: '(("class" "footnoteref"))
	(make element
	  gi: "A"
	  attributes: (list (list "href" (string-append "#footnote-" num)))
	  (literal num))))))

(mode footnote-def
  (element FOOTNOTE
    (let ((num (format-number (element-number (current-node)) "1")))
      (make element
	gi: "BLOCKQUOTE"
	attributes: '(("class" "footnote"))
	(make sequence
	  (make empty-element
	    gi: "P")
	  (make element
	    gi: "A"
	    attributes: (list (list "name" (string-append "footnote-" num)))
	    (make element
	      gi: "SUP"
	      attributes: '(("class" "footnote"))
	      (literal num)))
	  (process-children))))))

(element (CAUTION TITLE)
  (make element
      gi: "H5"))

(element (IMPORTANT TITLE)
  (make element
      gi: "H5"))

(element (WARNING TITLE)
  (make element
      gi: "H5"))

(element (NOTE TITLE)
  (make element
      gi: "H5"))

(element (TIP TITLE)
  (make element
      gi: "H5"))

(element (EXAMPLE TITLE)
  (make element
      gi: "H5"))

(element (BIBLIOENTRY TITLE)
  (make element
      gi: "H3"))

(element (SIDEBAR)
  (make sequence
    (make empty-element
      gi: "P")
    (make element
      gi: "TABLE"
      attributes: '(("border" "1")
		    ("bgcolor" "#f0f0f0")
		    ("width" "100%"))
      (make element
	gi: "TR"
	(make element
	  gi: "TD"
	  (process-children))))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; lists

(element ITEMIZEDLIST
  (make sequence
    (make empty-element
      gi: "P")
    (make-anchor)
    (make element
      gi: "UL")))

(element ORDEREDLIST
  (make sequence
    (make empty-element
      gi: "P")
    (make-anchor)
    (make element
      gi: "OL")))

(element (ITEMIZEDLIST LISTITEM)
  (make sequence
    (make empty-element
      gi: "LI")
    (process-children)
    (make empty-element
      gi: "P")))

(element (ORDEREDLIST LISTITEM)
  (make sequence
    (make empty-element
      gi: "LI")
    (process-children)
    (make empty-element
      gi: "P")))

(element VARIABLELIST
  (make sequence
    (make empty-element
      gi: "P")
    (make-anchor)
    (make element
      gi: "DL")))

(element VARLISTENTRY (process-children))

(element (VARLISTENTRY LISTITEM)
  (make sequence
    (make empty-element
      gi: "DD")
    (process-children)
    (make empty-element
      gi: "P")))

(element (VARLISTENTRY TERM)
  (let ((content (make sequence
		   (make-anchor)
		   (maybe-bold-children))))
    (make sequence
      (make empty-element
	gi: "DT")
      (cond ((equal? (inherited-element-attribute-string
		      "VARIABLELIST" "role") "bold")
	     (make element
	       gi: "B"
	       content))
	    ((equal? (inherited-element-attribute-string
		      "VARIABLELIST" "role") "fixed")
	     (make element
	       gi: "TT"
	       content))
	    (#t content)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; glossary

(element GLOSSTERM (process-children))

(element GLOSSDIV
  (make sequence
    (make empty-element
      gi: "P")
    (process-children)))

(element (GLOSSENTRY GLOSSSEE)
  (make sequence
    (make empty-element
      gi: "DD")
    (literal "See ")
    (make element
      gi: "A" 
      attributes: (list (list "href" 
			      (string-append "#"
					     (if
					      (string?
					       (attribute-string "otherterm"))
					      (attribute-string "otherterm")
					      (gloss-entry-name
					       (current-node))))))
      (if (string? (attribute-string "otherterm"))
	  (with-mode glosssee
	    (process-element-with-id
	     (attribute-string "OTHERTERM")))
	  (process-children-trim)))
    (make empty-element
      gi: "P")))

(define (gloss-entry-name glossterm)
  (string-append "gloss-" (data glossterm)))

(element (GLOSSENTRY GLOSSTERM)
  (make sequence
    (make empty-element
      gi: "DT")
    (make element
      gi: "A" 
      attributes: (list (list "name"
			      (if (string? (inherited-attribute-string "ID"))
				  (inherited-attribute-string "ID")
				  (gloss-entry-name (current-node)))))
      (empty-sosofo))
    (process-children)))

(element GLOSSENTRY
  (make element
    gi: "DL"
    (process-children)))

(element (GLOSSENTRY GLOSSDEF)
  (make sequence
    (make empty-element
      gi: "DD")
    (process-children)
    (make empty-element
      gi: "P")))

(element GLOSSSEEALSO
  (make sequence
    (if (first-sibling?)
	(make sequence
	  (make empty-element
	    gi: "P")
	  (make element
	    gi: "EM"
	    (literal "See also ")))
	(make sequence
	  (make element
	    gi: "EM"
	    (literal ", "))))
    (make element
      gi: "a"
      attributes: (list (list "href"
			      (string-append
			       "#"
			       (attribute-string
				"OTHERTERM"))))
      (with-mode glosssee
	(process-element-with-id
	 (attribute-string "OTHERTERM"))))))

;; This is referenced within the GLOSSSEE and GLOSSSEEALSO element
;; construction expressions.  The OTHERTERM attributes on GLOSSSEE and
;; GLOSSSEEALSO (should) refer to GLOSSENTRY elements but we're only
;; interested in the text within the GLOSSTERM.  Discard the revision
;; history and the definition from the referenced term.
(mode glosssee
  (element GLOSSTERM
    (process-children))
  (element REVHISTORY
    (empty-sosofo))
  (element GLOSSDEF
    (empty-sosofo)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; index

(define (index-entry-name indexterm)
  (string-append "index." (format-number (element-number indexterm) "1")))

(element INDEXTERM
  (make sequence
    (make-anchor)
    (make element
      gi: "A"
      attributes: (list (list "name" (index-entry-name (current-node))))
      (literal ""))
    (empty-sosofo)))

; DIY string-ci>?

(define (string-ci>? s1 s2)
  (let ((len1 (string-length s1))
	(len2 (string-length s2)))
    (let loop ((i 0))
      (cond ((= i len1) #f)
	    ((= i len2) #t)
	    (#t (let ((c1 (index-char-val (string-ref s1 i)))
		      (c2 (index-char-val (string-ref s2 i))))
		  (cond
		   ((= c1 c2) (loop (+ i 1)))
		   (#t (> c1 c2)))))))))

(define (equal-ci? s1 s2)
  (let ((len1 (string-length s1))
	(len2 (string-length s2)))
    (if (= len1 len2) 
	(let loop ((i 0))
	  (if (= i len1)
	      #t
	      (let ((c1 (index-char-val (string-ref s1 i)))
		    (c2 (index-char-val (string-ref s2 i))))
		(if (= c1 c2)
		    (loop (+ i 1))
		    #f))))
	#f)))

(define (index-char-val ch)
  (case ch
    ((#\A #\a) 65)
    ((#\B #\b) 66)
    ((#\C #\c) 67)
    ((#\D #\d) 68)
    ((#\E #\e) 69)
    ((#\F #\f) 70)
    ((#\G #\g) 71)
    ((#\H #\h) 72)
    ((#\I #\i) 73)
    ((#\J #\j) 74)
    ((#\K #\k) 75)
    ((#\L #\l) 76)
    ((#\M #\m) 77)
    ((#\N #\n) 78)
    ((#\O #\o) 79)
    ((#\P #\p) 80)
    ((#\Q #\q) 81)
    ((#\R #\r) 82)
    ((#\S #\s) 83)
    ((#\T #\t) 84)
    ((#\U #\u) 85)
    ((#\V #\v) 86)
    ((#\W #\w) 87)
    ((#\X #\x) 88)
    ((#\Y #\y) 89)
    ((#\Z #\z) 90)

((#\ ) 32)

((#\0) 48)
    ((#\1) 49)
    ((#\2) 50)
    ((#\3) 51)
    ((#\4) 52)
    ((#\5) 53)
    ((#\6) 54)
    ((#\7) 55)
    ((#\8) 56)
    ((#\9) 57)

; laziness precludes me from filling this out further
    (else 0)))

(define (string->number-list s)
  (let loop ((i (- (string-length s) 1))
	     (l '()))
    (if (< i 0)
	l
	(loop (- i 1) (cons (index-char-val (string-ref s i)) l)))))

(define (number-list>? l1 l2)
  (cond ((null? l1) #f)
	((null? l2) #t)
	((= (car l1) (car l2))
	 (number-list>? (cdr l1) (cdr l2)))
	(#t (> (car l1) (car l2)))))

; return the string data for a given index entry

(define (get-index-entry-data entry)
  (let ((primary (select-elements (children entry) "PRIMARY"))
	(secondary (select-elements (children entry) "SECONDARY")))
    (if (node-list-empty? secondary)
	(data primary)
	(string-append (data primary) " - " (data secondary)))))

(define (make-index-entry entry)
  (let ((text (get-index-entry-data entry)))
    (cons text
	  (make sequence
	    (make empty-element
	      gi: "LI")
	    (make element
	      gi: "A"
	      attributes: (list (list "href"
				      (string-append (link-file-name
						      entry)
						     "#"
						     (index-entry-name
						      entry))))
	      (literal text))))))

(define (build-index nl)
  (let loop ((result '())
	     (nl nl))
    (if (node-list-empty? nl)
	result
	(loop (cons (make-index-entry (node-list-first nl)) result)
	      (node-list-rest nl)))))

(define (sort-index il)
  (letrec ((list-head (lambda (l n)
			(if (> n 0)
			    (cons (car l) (list-head (cdr l) (- n 1)))
			    '())))
	   (merge (lambda (il1 il2)
		    (cond ((null? il1) il2)
			  ((null? il2) il1)
			  ((string-ci>? (car (car il1)) (car (car il2)))
			   (cons (car il2) (merge il1 (cdr il2))))
			  (#t
			   (cons (car il1) (merge (cdr il1) il2)))))))
    (let* ((ll (length il))
	   (ldiv2 (quotient ll 2)))
      (if (> 2 ll)
	  il
	  (merge (sort-index (list-head il ldiv2))
		 (sort-index (list-tail il ldiv2)))))))

(define (output-index il)
  (let extract-and-append ((il il)
			   (result (empty-sosofo)))
    (if (null? il)
	result
	(extract-and-append (cdr il) (sosofo-append result (cdr (car il)))))))

(define (make-index)
  (make sequence
    (make element
      gi: "H1"
      (make element
	gi: "A"
	attributes: (list (list "name" "INDEXTOP"))
	(literal "Index")))
    (make element
      gi: "UL"
      (output-index
       (sort-index
	(build-index (select-elements (descendants (current-node))
				      "INDEXTERM")))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; links & cross-references

(define (link-file-name target)
  (if %no-split-output%
      ""
      (string-append
       %output-basename%
       (cond ((equal? (gi target) "BOOK") "")
	     
	     ((equal? (gi target) "APPENDIX")
	      (string-append
	       "-APP-"
	       (format-number (child-number target) "A")))

((or (equal? (gi target) "CHAPTER")
		  (equal? (gi target) "ARTICLE")
		  (equal? (gi target) "GLOSSARY"))
	      (string-append
	       "-"
	       (substring (gi target) 0 3)
	       "-"
	       (format-number (child-number target) "1")))

((equal? (gi target) "REFENTRY")
	      (string-append
	       "-REF-"
	       (number->string (all-element-number target))))

((ancestor-child-number "APPENDIX" target)
	      (string-append
	       "-APP-"
	       (format-number (ancestor-child-number "APPENDIX" target) "A")))
	     ((ancestor-child-number "CHAPTER" target)
	      (string-append
	       "-CHA-"
	       (format-number (ancestor-child-number "CHAPTER" target) "1")))

((ancestor-child-number "ARTICLE" target)
	      (string-append
	       "-ART-"
	       (format-number (ancestor-child-number "ARTICLE" target) "1")))
	     
	     ((ancestor-child-number "GLOSSARY" target)
	      (string-append
	       "-GLO-"
	       (format-number (ancestor-child-number "GLOSSARY" target) "1")))

(#t 
	      (string-append
	       "-XXX-"
	       (number->string (all-element-number target)))))
       %output-suffix%)))

(element LINK
  (let* ((target (element-with-id (attribute-string "linkend")
				  (book-node)))
	 (target-file-name (link-file-name target)))
    (make element
      gi: "A"
      attributes: (list
		   (list "href" 
			 (string-append 
			  target-file-name
			  "#"
			  (attribute-string "linkend")))))))
(element ULINK
  (make element 
    gi: "A"
    attributes: (list
		 (list "href" (attribute-string "url")))))

(element XREF
  (let* ((linkend (attribute-string "linkend"))
	 (target (element-with-id linkend (book-node)))
	 (target-gi (gi target)))
    (make element
      gi: "A"
      attributes: (append
		   (list (list "href" (string-append (link-file-name target) 
						     "#"
						     linkend)))
		   (if (equal? target-gi "CO")
		       ;;; XREF must be in same file as CO for
		       ;;; backlink to work correctly
		       (list (list "name" (string-append "backlink-" linkend)))
		       '()))
      (if (equal? target-gi "CO")
	  (literal (or (attribute-string "label" target)
		       "Unlabeled CO"))
	  (with-mode extract-xref-text
	    (process-node-list target))))))

(mode extract-xref-text
  (default
    (let ((titles (select-elements (children (current-node)) "TITLE")))
      (if (node-list-empty? titles)
	  (literal (string-append "Reference to " (id)))
	  (with-mode extract-title-text
	    (process-node-list (node-list-first titles)))))))

(element CO
  (if (id)
      (make element
	gi: "A"
	attributes: (list (list "name" (id))
			  (list "href" (string-append "#backlink-" (id))))
	(make element
	  gi: "SPAN"
	  attributes: '(("class" "co"))
	  (literal (or (attribute-string "label")
		       "Unlabeled CO"))))
      (empty-sosofo)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; figures

(element FIGURE
  (let ((gubbins (make sequence
		   (make empty-element
		     gi: "P")
		   (make-anchor)
		   (process-children)
		   (make empty-element
		     gi: "P"))))
    (cond (%stylesheet-name%
	   (make element
	     gi: "DIV"
	     attributes: '(("class" "figure"))
	     gubbins))
	  (%centre-figures%
	   (make element
	     gi: "CENTER"
	     gubbins))
	  (#t gubbins))))

(element (FIGURE TITLE)
  (make sequence
    (make element
      gi: "H5"
      attributes: '(("class" "figure"))
      (make sequence
	(literal "Figure: ")
	(process-children-trim)))
    (make empty-element
      gi: "P")))

(element GRAPHIC
  (let ((img
	 (make sequence
	   (make empty-element
	     gi: "P")
	   (make empty-element
	     gi: "IMG"
	     attributes: (let ((filename (string-append
					  (or (and %graphic-directory%
						   (string-append %graphic-directory%
								  "/"))
					      "")
					  (attribute-string "fileref")
					  "."
					  (or (attribute-string "format")
					      %default-graphic-format%))))
			   (list (list "src" filename)
				 (list "alt" filename)))))))
    (if (equal?
	 (attribute-string "align")
	 "CENTER")
	(if %stylesheet-name%
	    (make element
	      gi: "DIV"
	      attributes: '(("class" "center"))
	      img)
	    (make element
	      gi: "CENTER"
	      img))
	img)))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; tables

(define (make-table-attributes)
  (append (if (equal? (attribute-string "frame") "ALL")
	      '(("border" "1") ("cellpadding" "2"))
	      '(("border" "0")))
;	  (let ((wantcolsep (equal? (attribute-string "colsep") "1"))
;		(wantrowsep (equal? (attribute-string "rowsep") "1")))
;	    (list
;	     (cond ((and wantrowsep wantcolsep) '("rules" "all"))
;		   (wantcolsep '("rules" "cols"))
;		   (wantrowsep '("rules" "rows"))
;		   (#t '("rules" "none")))))
	  ))

(element TABLE
  (let ((table (make sequence
		 (make-anchor)
		 (let ((tab (make sequence
			      (make element
				gi: "TABLE"
				attributes: (make-table-attributes)
				(make sequence
				  (make element
				    gi: "CAPTION"
				    (make sequence
				      (literal "Table: ")
				      (with-mode extract-title-text
					(process-first-descendant "TITLE"))))
				  (with-mode footnote-ref
				    (process-children))))
			      (with-mode footnote-def
				(process-node-list (select-elements (descendants (current-node)) "FOOTNOTE")))))
		       (roleattr (or (attribute-string "role") "")))
		   (if (or
			(equal-ci? roleattr
				   "centre")
			(equal-ci? roleattr
				   "center"))
		       (if %stylesheet-name%
			   (make element
			     gi: "DIV"
			     attributes: '(("class" "center"))
			     tab)
			   (make element
			     gi: "CENTER"
			     tab))
		       tab)))))
    (if %stylesheet-name%
	(make element
	  gi: "DIV"
	  attributes: '(("class" "table"))
	  table)
	(make sequence
	  (make empty-element gi: "P")
	  table
	  (make empty-element gi: "P")))))

(element (TABLE TITLE) (empty-sosofo))

(element INFORMALTABLE
  (make sequence
    (make empty-element
      gi: "P")
    (let ((tab (make element
		 gi: "TABLE"
		 attributes: (make-table-attributes)
		 (process-children)))
	  (roleattr (or (attribute-string "role")
			"")))
      (if (or
	   (equal-ci? roleattr
		      "centre")
	   (equal-ci? roleattr
		      "center"))
	  (if %stylesheet-name%
	      (make element
		gi: "DIV"
		attributes: '(("class" "center"))
		tab)
	      (make element
		gi: "CENTER"
		tab))
	  tab))
    (make empty-element
      gi: "P")))

(element ENTRY
  (process-children-trim))

; routine to convert a string consisting of a number followed by a
; unit (mm, cm, etc.) into a string consisting of just a number (in
; pixel units)

(define (to-pixels lenstring)
  (let ((num (or (string->number lenstring) 0)))
    (number->string
     (truncate (* %display-dpi%
		  0.01388888
		  (if (quantity? num)
		      (let ((qstr (quantity->string num)))
			;; this assumes the unit string is "pt1"
			(string->number (substring qstr 0 (- (string-length qstr) 3))))
		      num))))))

;; hairy stuff to get table entries to understand various attributes

(define (process-table-entry entry entrycolnum span entrygi colspecs cols)
  (make sequence
    ;; loop through COLSPECs looking for one that has the right
    ;; column number
    (let loop ((specs colspecs)
	       (nextspeccolnum 1))
      (if (node-list-empty? specs)
	  ;; we didn't find a COLSPEC for this column
	  (let ((alignattr (or (inherited-attribute-string "align" entry)
			       "left")))
	    (make empty-element
	      gi: entrygi
	      attributes: (append (list (list "align" alignattr))
				  (if (> span 1)
				      (list (list "colspan" (number->string span)))
				      '()))))
	  ;; look at next COLSPEC and see if it is for this column the
	  ;; column number can be explicitly given with a 'colnum'
	  ;; attribute or implicitly one more than the last column
	  ;; number
	  (let* ((spec (node-list-first specs))
		 (colnumattr (attribute-string "colnum" spec))
		 (speccolnum (or (and colnumattr (string->number colnumattr))
				 nextspeccolnum)))
	    (if (equal? speccolnum entrycolnum)
		;; we matched column numbers so extract the align
		;; attribute and do the right thing
		(let ((alignattr (or (attribute-string "align" entry)
				     (attribute-string "align" spec)
				     (inherited-attribute-string "align" entry)
				     "left"))
		      (widthattr (attribute-string "colwidth" spec)))
		  (make empty-element
		    gi: entrygi
		    attributes: (append (if alignattr
					    (list (list "align" alignattr))
					    '())
					(if (and widthattr (= span 1))
					    (list (if %stylesheet-name%
						      (list "style" (string-append "width: " (to-pixels widthattr)))
						      (list "width" (to-pixels widthattr))))
					    '())
					(if (> span 1)
					    (list (list "colspan" (number->string span)))
					    '()))))
		;; didn't match column number so look at next in list
		(loop (node-list-rest specs)
		      (+ speccolnum 1))))))
    (process-node-list entry)))

;; determine the column number (1, 2, ...) that corresponds to the
;; supplied column name from the supplied COLSPECs. If none of the
;; COLSPECs has a matching name and the supplied column name is
;; actually a number, we return that number.

(define (find-column-number colspecs colname)
  ;; loop searches for a COLSPEC whose name matches the supplied
  ;; column name
  (let loop ((specs colspecs)
	     (colnum 1))
    (if (node-list-empty? specs)
	;; if the column name is actually a number use that,
	;; otherwise, just return 1
	(or (string->number colname) 1)
	(let* ((spec (node-list-first specs))
	       (nameattr (attribute-string "colname" spec))
	       (colnumattr (attribute-string "colnum" spec))
	       (speccolnum (if colnumattr (string->number colnumattr) colnum)))
	  (if (equal? colname nameattr)
	      speccolnum
	      (loop (node-list-rest colspecs)
		    (+ speccolnum 1)))))))

;; determine the number of columns spanned by the given table entry
(define (columns-spanned entry)
  (let* ((colspecs (select-elements (ancestor "TGROUP" entry) "COLSPEC"))
	 (namest (attribute-string "namest" entry))
	 (nameend (attribute-string "nameend" entry)))
    (if (and namest nameend)
	(+ (- (find-column-number colspecs nameend)
	      (find-column-number colspecs namest))
	   1)
	1)))

(define (process-table-row sofar row entrygi entryprocessor)
  (sosofo-append sofar
		 (make empty-element gi: "TR")
		 (let loop ((entries (children row))
			    (result (empty-sosofo))
			    (colnum 1))
		   (if (node-list-empty? entries)
		       result
		       (let* ((entry (node-list-first entries))
			      (span (columns-spanned entry)))
			 (loop (node-list-rest entries)
			       (sosofo-append result
					      (entryprocessor entry
							      colnum
							      span
							      entrygi))
			       (+ colnum span)))))))

(define (process-table-group sofar group entrygi rowreducer)
  (sosofo-append sofar 
		 (node-list-reduce (select-elements (children group) "ROW")
				   (lambda (sofar new)
				     (rowreducer sofar new entrygi))
				   (empty-sosofo))))

(define (process-tgroup)
  (let* ((colspecs (select-elements (children (current-node)) "COLSPEC"))
	 (cols (string->number (attribute-string "cols")))
	 (entryprocessor (lambda (new colnum span entrygi)
			   (process-table-entry new colnum span entrygi colspecs cols)))
	 (rowreducer (lambda (sofar new entrygi)
		       (process-table-row sofar new entrygi entryprocessor)))
	 (groupreducer (lambda (sofar new entrygi)
			 (process-table-group sofar new entrygi rowreducer))))
    (make sequence
      (node-list-reduce (select-elements (children (current-node)) "THEAD")
			(lambda (sofar new)
			  (groupreducer sofar new "TH"))
			(empty-sosofo))
      (node-list-reduce (select-elements (children (current-node)) "TBODY")
			(lambda (sofar new)
			  (groupreducer sofar new "TD"))
			(empty-sosofo))
      (node-list-reduce (select-elements (children (current-node)) "TFOOT")
			(lambda (sofar new)
			  (groupreducer sofar new "TH"))
			(empty-sosofo)))))

(element TGROUP
  (process-tgroup))

(element ENTRYTBL
  (make element
    gi: "TABLE"
    attributes: (make-table-attributes)
    (process-tgroup)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; book info

(element BOOKINFO
  (make sequence
    (if %stylesheet-name%
	(make element
	  gi: "DIV"
	  attributes: '(("class" "bookinfo"))
	  (process-children))
	(make element
	  gi: "CENTER"
	  (process-children)))
    (cond ((not %no-make-toc%)
	   (make sequence
	     (make-fat-rule)
	     (make element
	       gi: "H2"
	       (literal "Contents"))
	     (make element
	       gi: "ul"
	       (with-mode make-toc-links
		 (process-node-list (book-node))))))
	  (#t (empty-sosofo)))))

(element AUTHORGROUP
  (let ((reducer (lambda (sofar new)
		   (sosofo-append sofar (make element
					  gi: "H2"
					  attributes: '(("class" "bookinfo"))
					  (process-node-list new))))))
    (make sequence
      (node-list-reduce (select-elements (children (current-node)) "AUTHOR")
			reducer
			(empty-sosofo))
      (node-list-reduce (select-elements (children (current-node)) "EDITOR")
			reducer
			(empty-sosofo))
      (node-list-reduce (select-elements (children (current-node)) "CORPAUTHOR")
			reducer
			(empty-sosofo)))))

(element (BIBLIOENTRY AUTHORGROUP)
  (let ((reducer (lambda (sofar new)
		   (sosofo-append sofar (make element
					  gi: "H3"
					  (process-node-list new))))))
    (make sequence
      (node-list-reduce (select-elements (children (current-node)) "AUTHOR")
			reducer
			(empty-sosofo))
      (node-list-reduce (select-elements (children (current-node)) "EDITOR")
			reducer
			(empty-sosofo))
      (node-list-reduce (select-elements (children (current-node)) "CORPAUTHOR")
			reducer
			(empty-sosofo)))))

(element (BOOKINFO DATE)
  (process-children-trim))

(element (BOOKINFO EDITION)
  (make sequence
    (literal "Edition ")
    (process-children-trim)))

(element COPYRIGHT
  (make element
    gi: "H4"
    (make sequence
      (make entity-ref
	name: "copy")
      (process-matching-children "HOLDER")
      (process-matching-children "YEAR"))))

(element HOLDER
  (make sequence
    (literal " ")
    (process-children-trim)))

(element YEAR
  (make sequence
    (literal " ")
    (process-children-trim)))

(element CORPAUTHOR
  (process-children-trim))

(element AUTHOR
  (process-children-trim))

(element EDITOR
  (process-children-trim))

(element CONFGROUP
  (process-children-trim))

(element CONFTITLE
  (make sequence
    (make empty-element
      gi: "BR")
    (make element gi: "I" (process-children))))

(element CONFDATES
  (make sequence
    (make empty-element
      gi: "BR")
    (process-children)))

(element HONORIFIC
  (make sequence
    (process-children-trim)
    (literal " ")))

(element FIRSTNAME
  (make sequence
    (process-children-trim)
    (literal " ")))

(element OTHERNAME
  (make sequence
    (process-children-trim)
    (literal " ")))

(element SURNAME
  (make sequence
    (process-children-trim)
    (literal " ")))

(element LINEAGE
  (make sequence
    (process-children-trim)
    (literal " ")))

(element TRADEMARK (process-children))

(element PUBLISHERNAME (process-children))

(element BIBLIOENTRY (process-children))

(element ACRONYM (process-children))

(element RELEASEINFO
  (make sequence
    (make empty-element
      gi: "BR")
    (make element gi: "B")))

(element AFFILIATION
  (make sequence
    (make element
      gi: "I")))

(element ORGNAME
  (make sequence
    (make empty-element
      gi: "BR")
    (process-children)))

(element JOBTITLE
  (make sequence
    (make empty-element
      gi: "BR")
    (process-children)))

(element ORGDIV
  (make sequence
    (make empty-element
      gi: "BR")
    (process-children)))

(element PUBLISHER
  (make sequence
    (make empty-element
      gi: "BR")
    (process-children)))

(element ISBN
  (make sequence
    (make empty-element
      gi: "BR")
    (process-children)))

(element PUBDATE
  (make sequence
    (make empty-element
      gi: "BR")
    (process-children)))

(element REVHISTORY
  (empty-sosofo))

(element LEGALNOTICE
  (make sequence
    (if %stylesheet-name%
	(make element
	  gi: "DIV"
	  attributes: '(("align" "left")))
	(process-children))))

(element KEYWORDSET
  (empty-sosofo))

(element SUBJECTSET
  (empty-sosofo))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TOC

(element LOF (empty-sosofo))

(element LOT (empty-sosofo))

(element TOC (empty-sosofo))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DIY TOC

(mode make-toc-links
  (element (BOOK)
    (sosofo-append
     (process-children)
     (cond ((not %no-make-index%)
	    (make sequence
	      (make empty-element
		gi: "LI")
	      (make element
		gi: "A"
		attributes: (list (list "href"
					(cond (%no-split-output% "#INDEXTOP")
					      (#t
					       (string-append (index-file-name)
							      "#INDEXTOP")))))
		(literal "Index"))))
	   (#t (empty-sosofo)))))
  (element (ARTICLE)
    (process-matching-children "SECT1"))
  (element (CHAPTER)
    (make-major-div-toc-links))
  (element (APPENDIX)
    (make-major-div-toc-links))
  (element (GLOSSARY)
    (make-major-div-toc-links))
  (element (SECT1)
    (make sequence
      (make empty-element
	gi: "LI")
      (let ((title-text (with-mode extract-title-text
			  (process-first-descendant "TITLE"))))
	(make element
	  gi: "A"
	  attributes: (list (list "href" (string-append (link-file-name (current-node))
							"#"
							(gi)
							(number->string (all-element-number (current-node))))))
	  title-text))
      (let ((refentries (select-elements (children (current-node)) "REFENTRY")))
	(if (node-list-empty? refentries)
	    (empty-sosofo)
	    (make element
	      gi: "ul"
	      (with-mode make-toc-links (process-node-list refentries)))))))
  (element (REFENTRY)
    (make sequence
      (make empty-element
	gi: "LI")
      (let ((title-text (process-first-descendant "REFMETA")))
	(make element
	  gi: "A"
	  attributes: (list (list "href" (string-append (link-file-name (current-node))
							"#"
							(gi)
							(number->string (all-element-number (current-node))))))
	  title-text))))

(default
    (empty-sosofo)))

(define (make-major-div-toc-links)
  (make sequence
    (make empty-element
      gi: "LI")
    (let ((title-text
	   (cond ((equal? (gi) "CHAPTER")
		  (make sequence
		    (literal (string-append "Chapter "
					    (format-number
					     (element-number (current-node))
					     "1")
					    " - "))
		    (with-mode extract-title-text
		      (process-first-descendant "TITLE"))))

((equal? (gi) "APPENDIX")
		  (make sequence
		    (literal
		     (string-append "Appendix "
				    (format-number
				     (element-number (current-node))
				     "A")
				    " - "))
		    (with-mode extract-title-text
		      (process-first-descendant "TITLE"))))

((equal? (gi) "GLOSSARY") (literal "Glossary"))
		     
		 (#t
		  (with-mode extract-title-text
		    (process-first-descendant "TITLE"))))))
      (make element
	gi: "A"
	attributes: (list (list "href" (string-append (link-file-name (current-node))
						      "#"
						      (gi)
						      (number->string (all-element-number (current-node))))))
	title-text))
    (let ((wanted (node-list-reduce (children (current-node))
				    (lambda (sofar new)
				      (if (or (equal? (gi new) "SECT1")
					      (equal? (gi new) "REFENTRY"))
					  (node-list sofar new)
					  sofar))
				    (node-list))))
      (if (node-list-empty? wanted)
	(empty-sosofo)
	(make element
	    gi: "UL"
	    (with-mode make-toc-links (process-node-list wanted)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; make the unimplemented bits stand out

(default
  (make element
    gi: "FONT"
    attributes: '(("color" "red"))
    (make sequence
      (literal (string-append "<" (gi) ">"))
      (process-children)
      (literal (string-append "</" (gi) ">")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; standard subroutines

(define (node-list-reduce nl combine init)
  (if (node-list-empty? nl)
      init
      (node-list-reduce (node-list-rest nl)
                        combine
                        (combine init (node-list-first nl)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; various homebrew subroutines

(define (book-node)
  (cond ((equal? (gi) "BOOK") (current-node))
	(#t (ancestor "BOOK"))))

(define (make-fat-rule)
  (make empty-element
    gi: "HR"
    attributes: (if %stylesheet-name%
		    '(("class" "fat"))
		    '(("size" "5")))))

(define (make-thin-rule)
  (make empty-element
    gi: "HR"
    attributes: (if %stylesheet-name%
		    '(("class" "thin"))
		    '(("size" "2")))))

(define (index-file-name)
  (string-append %output-basename%
		 "-IND"
		 %output-suffix%))

(define (chap-app-head-label chap-or-app)
  (let ((label
	 (attribute-string "label" (ancestor chap-or-app))))
    (string-append 
     chap-or-app
     " "
     (if label
	 (if (equal? label "auto")
	     (format-number
	      (element-number (ancestor chap-or-app))
	      (if (equal? chap-or-app "Chapter") "1" "A"))
	   label)
       (format-number
	(element-number (ancestor chap-or-app))
	(if (equal? chap-or-app "Chapter") "1" "A")))
     ". ")))

(define (make-anchor)
  (make sequence
    (make element
      gi: "A"
      attributes: (list (list "name" (string-append (gi)
						    (number->string (all-element-number (current-node))))))
      (literal ""))
    (if (id)
	(make element
	  gi: "A"
	  attributes: (list (list "name" (id)))
	  (literal ""))
	(empty-sosofo))))

(define (make-color-para color)
  (if %stylesheet-name%
      (make element
	gi: "DIV" 
	attributes: (list (list "class" (string-append "{color: " color "}")))
	(make-special-para))
      (make element
	gi: "FONT"
	attributes: (list (list "color" color))
	(make-special-para))))

(define (make-special-para)
  (make sequence
    (make empty-element
      gi: "P")
    (make element
      gi: "B"
      (literal (string-append (gi) ":")))
    (make element
      gi: "BLOCKQUOTE"
      (process-children))))

(define (maybe-bold-children)
  (cond ((equal? (attribute-string "role")
		 "bold")
	 (make element
	   gi: "B"
	   (process-children-trim)))
	(#t (process-children-trim))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the end

Places

File dbtohtml.dsl of Package docbook-dsssl-stylesheets (Revision 1abe1e9020cb4b9f512177047b97176d)

Places