;; $Id: dbcallou.dsl,v 1.4 2003/04/26 18:36:22 adicarlo Exp $
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://docbook.sourceforge.net/projects/dsssl/
;;
;; The support provided below is a little primitive because there's no way
;; to do line-addressing in Jade.
;;
;; CO's are supported with the CO element or, in SCREENCO and
;; PROGRAMLISTINGCO only, AREAs.
;;
;; Notes on the use of AREAs:
;;
;; - Processing is very slow. Jade loops through each AREA for
;; every column on every line.
;; - Only the LINECOLUMN units are supported, and they are #IMPLIED
;; - If a COORDS only specifies a line, the %callout-default-col% will
;; be used for the column.
;; - If the column is beyond the end of the line, that will work OK, but
;; if more than one callout has to get placed beyond the end of the same
;; line, that doesn't work so well.
;; - Embedded tabs foul up the column counting.
;; - Embedded markup fouls up the column counting.
;; - Embedded markup with embedded line breaks fouls up the line counting.
;; - The callout bugs occur immediately before the LINE COLUMN specified.
;; - You can't point to an AREASET, that doesn't make any sense in HTML
;; since it would imply a one-to-many link
;;
;; There's still no support for a stylesheet drawing the callouts on a
;; GRAPHIC, and I don't think there ever will be.
;;
(element areaspec (empty-sosofo))
(element area (empty-sosofo))
(element areaset (empty-sosofo))
(element co
($callout-mark$ (current-node) #t))
(element programlistingco (process-children))
(element screenco (process-children))
(element graphicco (process-children))
(element (screenco screen)
($callout-verbatim-display$ %indent-screen-lines% %number-screen-lines%))
(element (programlistingco programlisting)
($callout-verbatim-display$ %indent-programlisting-lines%
%number-programlisting-lines%))
;; ----------------------------------------------------------------------
(define ($callout-bug$ conumber)
(let ((number (if conumber (format-number conumber "1") "0")))
(if conumber
(if %callout-graphics%
(if (<= conumber %callout-graphics-number-limit%)
(make empty-element gi: "IMG"
attributes: (list (list "SRC"
(root-rel-path
(string-append
%callout-graphics-path%
number
%stock-graphics-extension%)))
(list "HSPACE" "0")
(list "VSPACE" "0")
(list "BORDER" "0")
(list "ALT"
(string-append
"(" number ")"))))
(make element gi: "B"
(literal "(" (format-number conumber "1") ")")))
(make element gi: "B"
(literal "(" (format-number conumber "1") ")")))
(make element gi: "B"
(literal "(??)")))))
(define ($callout-mark$ co anchor?)
;; Print the callout mark for co
(let* ((id (attribute-string (normalize "id") co))
(attr (if anchor?
(list (list "NAME" id))
(list (list "HREF" (href-to co))))))
(make element gi: "A"
attributes: attr
(if (equal? (gi co) (normalize "co"))
($callout-bug$ (if (node-list-empty? co)
#f
(child-number co)))
(let ((areanum (if (node-list-empty? co)
0
(if (equal? (gi (parent co)) (normalize "areaset"))
(absolute-child-number (parent co))
(absolute-child-number co)))))
($callout-bug$ (if (node-list-empty? co)
#f
areanum)))))))
(define ($look-for-callout$ line col #!optional (eol? #f))
;; Look to see if a callout should be printed at line col, and print
;; it if it should
(let* ((areaspec (select-elements (children (parent (current-node)))
(normalize "areaspec")))
(areas (expand-children (children areaspec)
(list (normalize "areaset")))))
(let loop ((areanl areas))
(if (node-list-empty? areanl)
(empty-sosofo)
(make sequence
(if ($callout-area-match$ (node-list-first areanl) line col eol?)
($callout-area-format$ (node-list-first areanl) line col eol?)
(empty-sosofo))
(loop (node-list-rest areanl)))))))
(define ($callout-area-match$ area line col eol?)
;; Does AREA area match line col?
(let* ((coordlist (split (attribute-string (normalize "coords") area)))
(aline (string->number (car coordlist)))
(acol (if (null? (cdr coordlist))
#f
(string->number (car (cdr coordlist)))))
(units (if (inherited-attribute-string (normalize "units") area)
(inherited-attribute-string (normalize "units") area)
(normalize "linecolumn"))))
(and (equal? units (normalize "linecolumn"))
(or
(and (equal? line aline)
(equal? col acol))
(and (equal? line aline)
eol?
(or (not acol) (> acol col)))))))
(define ($callout-area-format$ area line col eol?)
;; Format AREA area at the appropriate place
(let* ((coordlist (split (attribute-string (normalize "coords") area)))
(aline (string->number (car coordlist)))
(acol (if (null? (cdr coordlist))
#f
(string->number (car (cdr coordlist))))))
(if (and (equal? line aline)
eol?
(or (not acol) (> acol col)))
(make sequence
(let loop ((atcol col))
(if (>= atcol (if acol acol %callout-default-col%))
(empty-sosofo)
(make sequence
(literal " ")
(loop (+ atcol 1)))))
($callout-mark$ area #t))
($callout-mark$ area #t))))
(define ($callout-verbatim-display$ indent line-numbers?)
(let* ((content (make element gi: "PRE"
attributes: (list
(list "CLASS" (gi)))
($callout-verbatim-content$ indent line-numbers?))))
(if %shade-verbatim%
(make element gi: "TABLE"
attributes: ($shade-verbatim-attr$)
(make element gi: "TR"
(make element gi: "TD"
content)))
content)))
(define ($callout-verbatim-content$ indent line-numbers?)
;; Print linespecific content in a callout with line numbers
(make sequence
($line-start$ indent line-numbers? 1)
(let loop ((kl (children (current-node)))
(linecount 1)
(colcount 1)
(res (empty-sosofo)))
(if (node-list-empty? kl)
(sosofo-append res
($look-for-callout$ linecount colcount #t)
(empty-sosofo))
(loop
(node-list-rest kl)
(if (char=? (node-property 'char (node-list-first kl)
default: #\U-0000) #\U-000D)
(+ linecount 1)
linecount)
(if (char=? (node-property 'char (node-list-first kl)
default: #\U-0000) #\U-000D)
1
(if (char=? (node-property 'char (node-list-first kl)
default: #\U-0000) #\U-0000)
colcount
(+ colcount 1)))
(let ((c (node-list-first kl)))
(if (char=? (node-property 'char c default: #\U-0000)
#\U-000D)
(sosofo-append res
($look-for-callout$ linecount colcount #t)
(process-node-list c)
($line-start$ indent
line-numbers?
(+ linecount 1)))
(sosofo-append res
($look-for-callout$ linecount colcount)
(process-node-list c)))))))))
;; EOF dbcallout.dsl