;; $Id: db31.dsl,v 1.6 1999/07/30 13:28:50 nwalsh Exp $
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://nwalsh.com/docbook/dsssl/
;;

;; This module implements support for elements introduced in DocBook 3.1.
;; When DocBook 3.1 is officially released, these rules will get folded
;; into more appropriate modules.

;; ======================================================================
;; MediaObject and friends...

(define preferred-mediaobject-notations
  (list "JPG" "JPEG" "linespecific"))

(define preferred-mediaobject-extensions
  (list "jpeg" "jpg" "png" "avi" "mpg" "mpeg" "qt"))

(define acceptable-mediaobject-extensions
  (list "gif" "bmp"))

(define acceptable-mediaobject-notations
  (list "GIF" "GIF87a" "GIF89a" "BMP"))

(define (data-filename dataobj)
  (let ((entityref (attribute-string (normalize "entityref") dataobj))
	(fileref   (attribute-string (normalize "fileref") dataobj)))
    (if fileref
	fileref
	(system-id-filename entityref))))

(define (find-displayable-object objlist notlist extlist)
  (let loop ((nl objlist))
    (if (node-list-empty? nl)
	(empty-node-list)
	(let* ((objdata  (node-list-filter-by-gi
			  (children (node-list-first nl))
			  (list (normalize "videodata")
				(normalize "audiodata")
				(normalize "imagedata"))))
	       (filename (data-filename objdata))
	       (extension (file-extension filename))
	       (notation (attribute-string (normalize "format") objdata)))
	  (if (or (member notation notlist)
		  (member extension extlist))
	      (node-list-first nl)
	      (loop (node-list-rest nl)))))))

(define (select-displayable-object objlist)
  (let ((pref (find-displayable-object objlist 
				       preferred-mediaobject-notations
				       preferred-mediaobject-extensions))
	(ok   (find-displayable-object objlist
				       acceptable-mediaobject-notations
				       acceptable-mediaobject-extensions)))
    (if (node-list-empty? pref)
	ok
	pref)))

(define ($mediaobject$)
  (let* ((objects (node-list-filter-by-gi
		   (children (current-node))
		   (list (normalize "videoobject")
			 (normalize "imageobject")
			 (normalize "audioobject"))))
	 (dobject (select-displayable-object objects))
	 (textobj (select-elements (children (current-node)) 
				   (normalize "textobject")))
	 (caption (select-elements (children (current-node))
				   (normalize "caption"))))
    (make sequence
      (if (node-list-empty? dobject)
	  (if (node-list-empty? textobj)
	      (empty-sosofo)
	      (process-node-list (node-list-first textobj)))
	  (process-node-list dobject))
      (process-node-list caption))))
  
(element mediaobject
  (make element gi: "DIV"
	attributes: (list (list "CLASS" (gi)))
	(make element gi: "P"
	      ($mediaobject$))))

(element inlinemediaobject
  (make element gi: "SPAN"
	attributes: (list (list "CLASS" (gi)))
	($mediaobject$)))

(element mediaobjectco
  (process-children))

(element imageobjectco
  (process-children))

(element objectinfo
  (empty-sosofo))

(element videoobject
  (process-children))

(element videodata
  (let ((filename (data-filename (current-node))))
    (make element gi: "EMBED"
	  attributes: (list (list "SRC" filename)))))

(element audioobject
  (process-children))

(element audiodata
  (let ((filename (data-filename (current-node))))
    (make element gi: "EMBED"
	  attributes: (list (list "SRC" filename)))))

(element imageobject
  (process-children))

(element imagedata
  (let* ((filename (data-filename (current-node)))
	 (mediaobj (parent (parent (current-node))))
	 (textobjs (select-elements (children mediaobj) 
				    (normalize "textobject")))
	 (alttext  (let loop ((nl textobjs) (alttext #f))
		     (if (or alttext (node-list-empty? nl))
			 alttext
			 (let ((phrase (select-elements 
					(children 
					 (node-list-first nl))
					(normalize "phrase"))))
			   (if (node-list-empty? phrase)
			       (loop (node-list-rest nl) #f)
			       (loop (node-list-rest nl)
				     (data (node-list-first phrase))))))))
	 (fileref   (attribute-string (normalize "fileref")))
	 (entityref (attribute-string (normalize "entityref")))
	 (format    (if (attribute-string (normalize "format"))
			(attribute-string (normalize "format"))
			(if entityref
			    (entity-notation entityref)
			    #f))))
    (if (equal? format (normalize "linespecific"))
	(if fileref 
	    (include-file fileref)
	    (include-file (entity-generated-system-id entityref)))
	(make element gi: "IMG"
	      attributes: (append
			   (list (list "SRC" filename))
			   (if alttext
			       (list (list "ALT" alttext))
			       '()))))))

(element textobject
  (make element gi: "DIV"
	attributes: (list (list "CLASS" (gi)))
	(process-children)))

(element caption
  (make element gi: "DIV"
	attributes: (list (list "CLASS" (gi)))
	(process-children)))

;; ======================================================================
;; InformalFigure

(element informalfigure
  ($informal-object$ %informalfigure-rules% %informalfigure-rules%))

;; ======================================================================
;; Colophon

(element colophon
  ($component$))

;; ======================================================================
;; section
;; sectioninfo

(element section ($section$))
(element (section title) (empty-sosofo))

;; ======================================================================
;; QandASet and friends

(define (qanda-defaultlabel)
  (normalize "number"))

(define (qanda-section-level)
  ;; FIXME: what if they nest inside each other?
  (let* ((enclsect (ancestor-member (current-node)
				    (list (normalize "section")
					  (normalize "simplesect")
					  (normalize "sect5")
					  (normalize "sect4")
					  (normalize "sect3")
					  (normalize "sect2")
					  (normalize "sect1")
					  (normalize "refsect3")
					  (normalize "refsect2")
					  (normalize "refsect1")))))
    (SECTLEVEL enclsect)))

(define (qandadiv-section-level)
  (let ((depth (length (hierarchical-number-recursive 
			(normalize "qandadiv")))))
    (+ (qanda-section-level) depth)))

(element qandaset
  (let ((title (select-elements (children (current-node)) 
				(normalize "title")))
	;; process title and rest separately so that we can put the TOC
	;; in the rigth place...
	(rest  (node-list-filter-by-not-gi (children (current-node))
					   (list (normalize "title")))))
    (make element gi: "DIV"
	  attributes: (list (list "CLASS" (gi)))
	  (process-node-list title)
	  (if ($generate-qandaset-toc$)
	      (process-qanda-toc)
	      (empty-sosofo))
	  (process-node-list rest))))

(element (qandaset title)
  (let* ((htmlgi  (string-append "H" (number->string 
				      (+ (qanda-section-level) 1)))))
    (make element gi: htmlgi
	  (process-children))))

(element qandadiv
  (make element gi: "DIV"
	attributes: (list (list "CLASS" (gi)))
	(process-children)))

(element (qandadiv title)
  (let* ((hnr     (hierarchical-number-recursive (normalize "qandadiv")
						 (current-node)))
	 (number  (let loop ((numlist hnr) (number "") (sep ""))
		    (if (null? numlist)
			number
			(loop (cdr numlist) 
			      (string-append number
					     sep
					     (number->string (car numlist)))
			      "."))))
	 (htmlgi  (string-append "H" (number->string 
				      (+ (qandadiv-section-level) 1)))))
    (make element gi: htmlgi
	  (make element gi: "A"
		attributes: (list (list "NAME" (element-id 
						(parent (current-node)))))
		(empty-sosofo))
	  (literal number ". ")
	  (process-children))))

(element qandaentry
  (make element gi: "DIV"
	attributes: (list (list "CLASS" (gi)))
	(process-children)))

(element question
  (let* ((chlist   (children (current-node)))
	 (firstch  (node-list-first chlist))
	 (restch   (node-list-rest chlist)))
    (make element gi: "DIV"
	  attributes: (list (list "CLASS" (gi)))
	  (make element gi: "P"
		(make element gi: "A"
		      attributes: (list (list "NAME" (element-id)))
		      (empty-sosofo))
		(make element gi: "B"
		      (literal (question-answer-label (current-node)) " "))
		(process-node-list (children firstch)))
	  (process-node-list restch))))

(element answer
  (let* ((inhlabel (inherited-attribute-string (normalize "defaultlabel")))
	 (deflabel (if inhlabel inhlabel (qanda-defaultlabel)))
	 (label    (attribute-string (normalize "label")))
	 (chlist   (children (current-node)))
	 (firstch  (node-list-first chlist))
	 (restch   (node-list-rest chlist)))
    (make element gi: "DIV"
	  attributes: (list (list "CLASS" (gi)))
	  (make element gi: "P"
		(make element gi: "B"
		      (literal (question-answer-label (current-node)) " "))
		(process-node-list (children firstch)))
	  (process-node-list restch))))

;; = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 

(define (process-qanda-toc #!optional (node (current-node)))
  (let* ((divs     (node-list-filter-by-gi (children node)
					   (list (normalize "qandadiv"))))
	 (entries  (node-list-filter-by-gi (children node)
					   (list (normalize "qandaentry"))))
	 (inhlabel (inherited-attribute-string (normalize "defaultlabel")))
	 (deflabel (if inhlabel inhlabel (qanda-defaultlabel))))
    (make element gi: "DL"
	  (with-mode qandatoc
	    (process-node-list divs))
	  (with-mode qandatoc
	    (process-node-list entries)))))

(mode qandatoc
  (element qandadiv
    (let ((title (select-elements (children (current-node))
				  (normalize "title"))))
      (make sequence
	(make element gi: "DT"
	      (process-node-list title))
	(make element gi: "DD"
	      (process-qanda-toc)))))
  
  (element (qandadiv title)
    (let* ((hnr     (hierarchical-number-recursive (normalize "qandadiv")
						   (current-node)))
	   (number  (let loop ((numlist hnr) (number "") (sep ""))
		      (if (null? numlist)
			  number
			  (loop (cdr numlist) 
				(string-append number
					       sep
					       (number->string (car numlist)))
				".")))))
      (make sequence
	(literal number ". ")
	(make element gi: "A"
	      attributes: (list (list "HREF" 
				      (href-to (parent (current-node)))))
	      (process-children)))))

  (element qandaentry
    (process-children))

  (element question
    (let* ((chlist   (children (current-node)))
	   (firstch  (node-list-first chlist)))
      (make element gi: "DT"
	    (literal (question-answer-label (current-node)) " ")
	    (make element gi: "A"
		  attributes: (list (list "HREF" (href-to (current-node))))
		  (process-node-list (children firstch))))))
  
  (element answer
    (empty-sosofo))
)

;; ======================================================================
;; constant

(element constant 
  ($mono-seq$))

;; ======================================================================
;; varname

(element varname
  ($mono-seq$))