;; $Id: dbgraph.dsl,v 1.6 2003/03/25 19:53:40 adicarlo Exp $
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://docbook.sourceforge.net/projects/dsssl/
;;

;; ==================== GRAPHICS ====================

(define (graphic-file filename)
  (let ((ext (file-extension filename)))
    (if (or (not filename)
	    (not %graphic-default-extension%)
	    (member ext %graphic-extensions%))
	filename
	(string-append filename "." %graphic-default-extension%))))

(define (graphic-attrs imagefile instance-alt)
  (let* ((grove    (sgml-parse image-library-filename))
	 (imagelib (node-property 'document-element 
				  (node-property 'grove-root grove)))
	 (images   (select-elements (children imagelib) "image"))
	 (image    (let loop ((imglist images))
		     (if (node-list-empty? imglist)
			 #f
			 (if (equal? (attribute-string 
				      "filename"
				      (node-list-first imglist))
				     imagefile)
			     (node-list-first imglist)
			     (loop (node-list-rest imglist))))))
	 (prop     (if image
		       (select-elements (children image) "properties")
		       #f))
	 (metas    (if prop
		       (select-elements (children prop) "meta")
		       #f))
	 (attrs    (if metas
		       (let loop ((meta metas) (attrlist '()))
			 (if (node-list-empty? meta)
			     attrlist
			     (if (equal? (attribute-string 
					  "imgattr"
					  (node-list-first meta))
					 "yes")
				 (loop (node-list-rest meta)
				       (append attrlist
					       (list 
						(list 
						 (attribute-string 
						  "name"
						  (node-list-first meta))
						 (attribute-string
						  "content"
						  (node-list-first meta))))))
				 (loop (node-list-rest meta) attrlist))))
		       '()))
	 (width    (if prop (attribute-string "width" prop) #f))
	 (height   (if prop (attribute-string "height" prop) #f))
	 (alttext  (if image
		       (select-elements (children image) "alttext")
		       (empty-node-list)))
	 (alt      (if instance-alt
		       instance-alt
		       (if (node-list-empty? alttext)
			   #f
			   (data alttext)))))
    (if (or width height alt (not (null? attrs)))
	(append
	 attrs
	 (if width   (list (list "WIDTH" width)) '())
	 (if height  (list (list "HEIGHT" height)) '())
	 (if (not (node-list-empty? alttext)) (list (list "ALT" alt)) '()))
	'())))

(define ($graphic$ fileref
		   #!optional (format #f) (alt #f) (align #f) (width #f) (height #f))
  (let ((img-attr  (append
		    (list     (list "SRC" (graphic-file fileref)))
		    (if align (list (list "ALIGN" align)) '())
		    (if width (list (list "WIDTH" width)) '())
		    (if height (list (list "HEIGHT" height)) '())
		    (if image-library (graphic-attrs fileref alt) '()))))
    (make empty-element gi: "IMG"
	  attributes: img-attr)))

(define ($img$ #!optional (nd (current-node)) (alt #f))
  ;; This function now supports an extension to DocBook.  It's
  ;; either a clever trick or an ugly hack, depending on your
  ;; point of view, but it'll hold us until XLink is finalized
  ;; and we can extend DocBook the "right" way.
  ;;
  ;; If the entity passed to GRAPHIC has the FORMAT
  ;; "LINESPECIFIC", either because that's what's specified or
  ;; because it's the notation of the supplied ENTITYREF, then
  ;; the text of the entity is inserted literally (via Jade's
  ;; read-entity external procedure).
  ;;
  (let* ((fileref   (attribute-string (normalize "fileref") nd))
	 (entityref (attribute-string (normalize "entityref") nd))
	 (format    (if (attribute-string (normalize "format") nd)
			(attribute-string (normalize "format") nd)
			(if entityref
			    (entity-notation entityref)
			    #f)))
	 (align     (attribute-string (normalize "align") nd))
	 (width     (attribute-string (normalize "width") nd))
	 (height    (attribute-string (normalize "depth") nd)))
    (if (or fileref entityref)
	(if (equal? format (normalize "linespecific"))
	    (if fileref
		(include-file fileref)
		(include-file (entity-generated-system-id entityref)))
	    (if fileref
		($graphic$ fileref format alt align width height)
		($graphic$ (system-id-filename entityref)
			   format alt align width height)))
	(empty-sosofo))))

(element graphic
  (make element gi: "P"
	($img$)))

(element inlinegraphic
  ($img$))

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

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

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

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

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

(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)))
	($img$ (current-node) 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)))