;; $Id: dbindex.dsl,v 1.5 2003/01/15 08:24:13 adicarlo Exp $
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://docbook.sourceforge.net/projects/dsssl/
;;
;; ................... INDEX TERMS (EMBEDDED MARKERS) ...................
(element indexterm
(if html-index
(let* ((id (if (attribute-string (normalize "id"))
(attribute-string (normalize "id"))
(generate-anchor))))
(make element gi: "A"
attributes: (list (list "NAME" id))
(empty-sosofo)))
(empty-sosofo)))
(element primary (empty-sosofo))
(element secondary (empty-sosofo))
(element tertiary (empty-sosofo))
(element see (empty-sosofo))
(element seealso (empty-sosofo))
;; =========================== INDEX ELEMENTS ===========================
(element (setindex title) (empty-sosofo))
(element setindex
(let ((preamble (node-list-filter-by-not-gi
(children (current-node))
(list (normalize "indexentry"))))
(entries (node-list-filter-by-gi
(children (current-node))
(list (normalize "indexentry")))))
(html-document
(with-mode head-title-mode
(literal (element-title-string (current-node))))
(make element gi: "DIV"
attributes: (list (list "CLASS" (gi)))
($component-separator$)
($component-title$)
(process-node-list preamble)
(if (node-list-empty? entries)
(empty-sosofo)
(make element gi: "DL"
(process-node-list entries)))))))
(element (index title) (empty-sosofo))
(element index
(let ((preamble (node-list-filter-by-not-gi
(children (current-node))
(list (normalize "indexentry"))))
(entries (node-list-filter-by-gi
(children (current-node))
(list (normalize "indexentry")))))
(html-document
(with-mode head-title-mode
(literal (element-title-string (current-node))))
(make element gi: "DIV"
attributes: (list (list "CLASS" (gi)))
($component-separator$)
($component-title$)
(process-node-list preamble)
(if (node-list-empty? entries)
(empty-sosofo)
(make element gi: "DL"
(process-node-list entries)))))))
(element (indexdiv title) (empty-sosofo))
(element indexdiv
(let ((preamble (node-list-filter-by-not-gi
(children (current-node))
(list (normalize "indexentry"))))
(entries (node-list-filter-by-gi
(children (current-node))
(list (normalize "indexentry")))))
(html-document
(with-mode head-title-mode
(literal (element-title-string (current-node))))
(make element gi: "DIV"
attributes: (list (list "CLASS" (gi)))
($section-separator$)
($section-title$)
(process-node-list preamble)
(if (node-list-empty? entries)
(empty-sosofo)
(make element gi: "DL"
(process-node-list entries)))))))
(define (break-node-list nodes breakatgi)
;; Given a _node_ list "PRIM SEC TERT SEC SEC TERT PRIM SEC PRIM PRIM"
;; and the breakatgi of "PRIM", returns the _list_ of _node_ lists:
;; '("PRIM SEC TERT SEC SEC TERT" "PRIM SEC" "PRIM" "PRIM")
(let loop ((nl nodes) (result '()) (curlist (empty-node-list)))
(if (node-list-empty? nl)
(if (node-list-empty? curlist)
result
(append result (list curlist)))
(if (equal? (gi (node-list-first nl)) breakatgi)
(loop (node-list-rest nl)
(if (node-list-empty? curlist)
result
(append result (list curlist)))
(node-list-first nl))
(loop (node-list-rest nl)
result
(node-list curlist (node-list-first nl)))))))
(define (process-primary primnode secnl)
(let ((see? (equal? (gi (node-list-first secnl))
(normalize "seeie")))
(seealso? (equal? (gi (node-list-first secnl))
(normalize "seealsoie")))
(second (break-node-list secnl (normalize "secondaryie"))))
(if (or see? seealso?)
(process-terminal primnode secnl #t)
(make sequence
(process-nonterminal primnode)
(if (node-list-empty? secnl)
(empty-sosofo)
(make element gi: "DD"
(make element gi: "DL"
(let sloop ((secs second))
(if (null? secs)
(empty-sosofo)
(make sequence
(let* ((nodes (car secs))
(sec (node-list-first nodes))
(terts (node-list-rest nodes)))
(process-secondary sec terts))
(sloop (cdr secs))))))))))))
(define (process-secondary secnode tertnl)
(let ((see? (equal? (gi (node-list-first tertnl))
(normalize "seeie")))
(seealso? (equal? (gi (node-list-first tertnl))
(normalize "seealsoie")))
(tert (break-node-list tertnl (normalize "tertiaryie"))))
(if (or see? seealso?)
(process-terminal secnode tertnl)
(make sequence
(process-nonterminal secnode)
(make element gi: "DD"
(make element gi: "DL"
(let tloop ((terts tert))
(if (null? terts)
(empty-sosofo)
(make sequence
(let* ((nodes (car terts))
(tert (node-list-first nodes))
(sees (node-list-rest nodes)))
(process-tertiary tert sees))
(tloop (cdr terts)))))))))))
(define (process-tertiary tertnode seenl)
(process-terminal tertnode seenl))
(define (process-terminal node seenl #!optional (output-id #f))
(let ((id (attribute-string (normalize "id") (parent node))))
(make sequence
(make element gi: "DT"
(if id
(make element gi: "A"
attributes: (list (list "NAME" id))
(empty-sosofo))
(empty-sosofo))
(process-node-list node))
(if (node-list-empty? seenl)
(empty-sosofo)
(make element gi: "DD"
(make element gi: "DL"
(let loop ((nl seenl))
(if (node-list-empty? nl)
(empty-sosofo)
(make sequence
(make element gi: "DT"
(process-node-list
(node-list-first nl)))
(loop (node-list-rest nl)))))))))))
(define (process-nonterminal node)
(make element gi: "DT"
(process-node-list node)))
(element indexentry
(let* ((primary (break-node-list (children (current-node))
(normalize "primaryie"))))
(make sequence
(let ploop ((prims primary))
(if (null? prims)
(empty-sosofo)
(make sequence
(let* ((nodes (car prims))
(prim (node-list-first nodes))
(secs (node-list-rest nodes)))
(process-primary prim secs))
(ploop (cdr prims))))))))
(element primaryie (process-children))
(element secondaryie (process-children))
(element tertiaryie (process-children))
(define (indexentry-link nd)
(let* ((preferred (not (node-list-empty?
(select-elements (children (current-node))
(normalize "emphasis"))))))
(make element gi: "A"
attributes: (list (list "HREF"
(attribute-string (normalize "url"))))
(process-children))))
(element (primaryie ulink)
(indexentry-link (current-node)))
(element (secondaryie ulink)
(indexentry-link (current-node)))
(element (tertiaryie ulink)
(indexentry-link (current-node)))
(element seeie
(let ((linkend (attribute-string (normalize "linkend"))))
(if linkend
(make element gi: "A"
attributes: (list (list "HREF"
(href-to (element-with-id linkend))))
(literal (gentext-element-name (current-node)))
(literal (gentext-label-title-sep (current-node)))
(process-children))
(make sequence
(literal (gentext-element-name (current-node)))
(literal (gentext-label-title-sep (current-node)))
(process-children)))))
(element seealsoie
(let* ((alinkends (attribute-string (normalize "linkends")))
(linkends (if alinkends
(split alinkends)
'()))
(linkend (if alinkends
(car linkends)
#f)))
(if linkend
(make element gi: "A"
attributes: (list (list "HREF"
(href-to (element-with-id linkend))))
(literal (gentext-element-name (current-node)))
(literal (gentext-label-title-sep (current-node)))
(process-children))
(make sequence
(literal (gentext-element-name (current-node)))
(literal (gentext-label-title-sep (current-node)))
(process-children)))))
;; =====================HTML INDEX PROCESSING ==============================
(define (htmlnewline)
(make formatting-instruction data: " "))
(define (htmlindexattr attr)
(if (attribute-string (normalize attr))
(make sequence
(make formatting-instruction data: attr)
(make formatting-instruction data: " ")
(make formatting-instruction data: (attribute-string
(normalize attr)))
(htmlnewline))
(empty-sosofo)))
(define (htmlindexterm)
(let* ((attr (gi (current-node)))
(content (data (current-node)))
(string (string-replace content " " " "))
(sortas (attribute-string (normalize "sortas"))))
(make sequence
(make formatting-instruction data: attr)
(if sortas
(make sequence
(make formatting-instruction data: "[")
(make formatting-instruction data: sortas)
(make formatting-instruction data: "]"))
(empty-sosofo))
(make formatting-instruction data: " ")
(make formatting-instruction data: string)
(htmlnewline))))
(define (htmlindexzone zone)
(let loop ((idlist (split zone)))
(if (null? idlist)
(empty-sosofo)
(make sequence
(htmlindexzone1 (car idlist))
(loop (cdr idlist))))))
(define (htmlindexzone1 id)
(let* ((target (ancestor-member (element-with-id id)
(append (book-element-list)
(division-element-list)
(component-element-list)
(section-element-list))))
(title (string-replace (element-title-string target) " " " ")))
(make sequence
(make formatting-instruction data: "ZONE ")
(make formatting-instruction data: (href-to target))
(htmlnewline)
(make formatting-instruction data: "TITLE ")
(make formatting-instruction data: title)
(htmlnewline))))
(mode htmlindex
;; this mode is really just a hack to get at the root element
(root (process-children))
(default
(if (node-list=? (current-node) (sgml-root-element))
(make entity
system-id: (html-entity-file html-index-filename)
(process-node-list (select-elements
(descendants (current-node))
(normalize "indexterm"))))
(empty-sosofo)))
(element indexterm
(let* ((target (ancestor-member (current-node)
(append (book-element-list)
(division-element-list)
(component-element-list)
(section-element-list))))
(title (string-replace (element-title-string target) " " " ")))
(make sequence
(make formatting-instruction data: "INDEXTERM ")
(make formatting-instruction data: (href-to target))
(htmlnewline)
(make formatting-instruction data: "INDEXPOINT ")
(make formatting-instruction data: (href-to (current-node)))
(htmlnewline)
(make formatting-instruction data: "TITLE ")
(make formatting-instruction data: title)
(htmlnewline)
(htmlindexattr "scope")
(htmlindexattr "significance")
(htmlindexattr "class")
(htmlindexattr "id")
(htmlindexattr "startref")
(if (attribute-string (normalize "zone"))
(htmlindexzone (attribute-string (normalize "zone")))
(empty-sosofo))
(process-children)
(make formatting-instruction data: "/INDEXTERM")
(htmlnewline))))
(element primary
(htmlindexterm))
(element secondary
(htmlindexterm))
(element tertiary
(htmlindexterm))
(element see
(htmlindexterm))
(element seealso
(htmlindexterm))
)