;; $Id: dbtable.dsl,v 1.3 2003/02/17 08:56:46 adicarlo Exp $
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://docbook.sourceforge.net/projects/dsssl/
;;
;; Table support completely reimplemented by norm 15/16 Nov 1997
;;
;; ======================================================================
;;
;; This code is intended to implement the SGML Open Exchange Table Model
;; (http://www.sgmlopen.org/sgml/docs/techpubs.htm) as far as is possible
;; in RTF. There are a few areas where this code probably fails to
;; perfectly implement the model:
;;
;; - Mixed column width units (4*+2pi) are not supported.
;; - The behavior that results from mixing relative units with
;; absolute units has not been carefully considered.
;; - TFOOT appears at the bottom of the table, but is not repeated
;; across the bottom of pages (RTF limitation).
;; - ENTRYTBL is not supported.
;; - Rotated tables (e.g. landscape tables in a portrait document)
;; cannot be supported in a simple-page-sequence
;;
;; ======================================================================
;;
;; My goal in reimplementing the table model was to provide correct
;; formatting in tables that use MOREROWS. The difficulty is that
;; correct formatting depends on calculating the column into which
;; an ENTRY will fall.
;;
;; This is a non-trivial problem because MOREROWS can hang down from
;; preceding rows and ENTRYs may specify starting columns (skipping
;; preceding ones).
;;
;; A simple, elegant recursive algorithm exists. Unfortunately it
;; requires calculating the column number of every preceding cell
;; in the entire table. Without memoization, performance is unacceptable
;; even in relatively small tables (5x5, for example).
;;
;; In order to avoid recursion, the algorithm used below is one that
;; works forward from the beginning of the table and "passes along"
;; the relevant information (column number of the preceding cell and
;; overhang from the MOREROWS in preceding rows).
;;
;; Unfortunately, this means that element construction rules
;; can't always be used to fire the appropriate rule. Instead,
;; each TGROUP has to process each THEAD/BODY/FOOT explicitly.
;; And each of those must process each ROW explicitly, then each
;; ENTRY/ENTRYTBL explicitly.
;;
;; ----------------------------------------------------------------------
;;
;; I attempted to simplify this code by relying on inheritence from
;; table-column flow objects, but that wasn't entirely successful.
;; Horizontally spanning cells didn't seem to inherit from table-column
;; flow objects that didn't specify equal spanning. There seemed to
;; be other problems as well, but they could have been caused by coding
;; errors on my part.
;;
;; Anyway, by the time I understood how I could use table-column
;; flow objects for inheritence, I'd already implemented all the
;; machinery below to "work it out by hand".
;;
;; ======================================================================
;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
;; ----------------------------------------------------------------------
;; A fairly large chunk of this code is in dbcommon.dsl!
;; ======================================================================
;;
;; Default value for FRAME= on tables
(define ($cals-frame-default$) (normalize "all"))
;; Default for COLSEP/ROWSEP if unspecified.
(define ($cals-rowsep-default$ #!optional (node (current-node)))
;; Return "0" for #f, "1" for #t
;; Default is to have rules if FRAME=ALL, otherwise not. Except
;; that a separator between HEAD and BODY is controlled by
;; %table-head-body-border%.
;;
(let* ((table (ancestor-member node ($table-element-list$)))
(frame (if (attribute-string (normalize "frame") table)
(attribute-string (normalize "frame") table)
($cals-frame-default$)))
(row (ancestor-member node (list (normalize "row")))))
(if (equal? frame (normalize "all"))
#t
(if (and (equal? (gi (parent row)) (normalize "thead"))
(last-sibling? row))
%table-head-body-border%
#f))))
(define ($cals-colsep-default$ #!optional (node (current-node)))
;; Default is to have rules if FRAME=ALL, otherwise not.
;;
(let* ((table (ancestor-member node ($table-element-list$)))
(frame (if (attribute-string (normalize "frame") table)
(attribute-string (normalize "frame") table)
($cals-frame-default$))))
(equal? frame (normalize "all"))))
;; Default for VALIGN if unspecified
(define ($cals-valign-default$) (normalize "top"))
;; Margins around cell contents
(define %cals-cell-before-row-margin% 3pt)
(define %cals-cell-after-row-margin% 3pt)
(define %cals-cell-before-column-margin% 3pt)
(define %cals-cell-after-column-margin% 3pt)
;; Inheritable start and end indent for cell contents
(define %cals-cell-content-start-indent% 2pt)
(define %cals-cell-content-end-indent% 2pt)
;; How to indent pgwide tables? (Non-pgwide tables get inherited-start-indent
(define %cals-pgwide-start-indent% %body-start-indent%)
;; What alignment should tables have on the page
(define %cals-display-align% 'start)
;; ----------------------------------------------------------------------
;; Table rule widths
(define %table-before-row-border% #t)
(define %table-after-row-border% #t)
(define %table-before-column-border% #t)
(define %table-after-column-border% #t)
(define %table-head-body-border% #t)
(define %table-cell-after-column-border% #t)
(define %table-cell-after-row-border% #t)
;;(define tbl-color-space
;; (color-space "ISO/IEC 10179:1996//Color-Space Family::Device RGB"))
;;
;;(define tbl-red (color tbl-color-space 1 0 0))
;;(define tbl-green (color tbl-color-space 0 1 0))
;;(define tbl-blue (color tbl-color-space 0 0 1))
(define calc-table-before-row-border
(if (boolean? %table-before-row-border%)
%table-before-row-border%
;; Avoid problems with the DSSSL compiler when
;; %table-before-row-border% is boolean.
(let ((border-width %table-before-row-border%))
(make table-border
line-thickness: border-width))))
(define calc-table-after-row-border
(if (boolean? %table-after-row-border%)
%table-after-row-border%
(let ((border-width %table-after-row-border%))
(make table-border
line-thickness: border-width))))
(define calc-table-before-column-border
(if (boolean? %table-before-column-border%)
%table-before-column-border%
(let ((border-width %table-before-column-border%))
(make table-border
line-thickness: border-width))))
(define calc-table-after-column-border
(if (boolean? %table-after-column-border%)
%table-after-column-border%
(let ((border-width %table-after-column-border%))
(make table-border
line-thickness: border-width))))
(define calc-table-head-body-border
(if (boolean? %table-head-body-border%)
%table-head-body-border%
(let ((border-width %table-head-body-border%))
(make table-border
line-thickness: border-width))))
(define calc-table-cell-after-column-border
(if (boolean? %table-cell-after-column-border%)
%table-cell-after-column-border%
(let ((border-width %table-cell-after-column-border%))
(make table-border
line-thickness: border-width))))
(define calc-table-cell-after-row-border
(if (boolean? %table-cell-after-row-border%)
%table-cell-after-row-border%
(let ((border-width %table-cell-after-row-border%))
(make table-border
line-thickness: border-width))))
;; ----------------------------------------------------------------------
;; Convert colwidth units into table-unit measurements
(define (colwidth-unit lenstr)
(if (string? lenstr)
(let ((number (length-string-number-part lenstr))
(units (length-string-unit-part lenstr)))
(if (string=? units "*")
(if (string=? number "")
(table-unit 1)
(table-unit (string->number number)))
(if (string=? units "")
;; no units, default to points
(* (string->number number) 1pt)
(let* ((unum (string->number number))
(uname (case-fold-down units)))
(case uname
(("mm") (* unum 1mm))
(("cm") (* unum 1cm))
(("in") (* unum 1in))
(("pi") (* unum 1pi))
(("pt") (* unum 1pt))
(("px") (* unum 1px))
;; unrecognized units; use points
(else (* unum 1pt)))))))
;; lenstr is not a string...probably #f
(table-unit 1)))
(define (cell-align cell colnum)
(let* ((entry (ancestor-member cell (list (normalize "entry")
(normalize "entrytbl"))))
(tgroup (find-tgroup entry))
(spanname (attribute-string (normalize "spanname") entry))
(calsalign (if (attribute-string (normalize "align") entry)
(attribute-string (normalize "align") entry)
(if (and spanname
(spanspec-align (find-spanspec spanname)))
(spanspec-align (find-spanspec spanname))
(if (colspec-align (find-colspec-by-number colnum))
(colspec-align (find-colspec-by-number colnum))
(if (tgroup-align tgroup)
(tgroup-align tgroup)
(normalize "left")))))))
(cond
((equal? calsalign (normalize "left")) 'start)
((equal? calsalign (normalize "center")) 'center)
((equal? calsalign (normalize "right")) 'end)
(else 'start))))
(define (cell-valign cell colnum)
(let* ((entry (ancestor-member cell (list (normalize "entry")
(normalize "entrytbl"))))
(row (ancestor (normalize "row") entry))
(tbody (ancestor-member cell (list (normalize "tbody")
(normalize "thead")
(normalize "tfoot"))))
(tgroup (ancestor (normalize "tgroup") entry))
(calsvalign (if (attribute-string (normalize "valign") entry)
(attribute-string (normalize "valign") entry)
(if (attribute-string (normalize "valign") row)
(attribute-string (normalize "valign") row)
(if (attribute-string (normalize "valign") tbody)
(attribute-string (normalize "valign") tbody)
($cals-valign-default$))))))
(cond
((equal? calsvalign (normalize "top")) 'start)
((equal? calsvalign (normalize "middle")) 'center)
((equal? calsvalign (normalize "bottom")) 'end)
(else 'start))))
;; ======================================================================
;; Element rules
(element tgroup
(let ((frame-attribute (if (inherited-attribute-string (normalize "frame"))
(inherited-attribute-string (normalize "frame"))
($cals-frame-default$))))
(make table
;; These values are used for the outer edges (well, the top, bottom
;; and left edges for sure; I think the right edge actually comes
;; from the cells in the last column
before-row-border: (if (cond
((equal? frame-attribute (normalize "all")) #t)
((equal? frame-attribute (normalize "sides")) #f)
((equal? frame-attribute (normalize "top")) #t)
((equal? frame-attribute (normalize "bottom")) #f)
((equal? frame-attribute (normalize "topbot")) #t)
((equal? frame-attribute (normalize "none")) #f)
(else #f))
calc-table-before-row-border
#f)
after-row-border: (if (cond
((equal? frame-attribute (normalize "all")) #t)
((equal? frame-attribute (normalize "sides")) #f)
((equal? frame-attribute (normalize "top")) #f)
((equal? frame-attribute (normalize "bottom")) #t)
((equal? frame-attribute (normalize "topbot")) #t)
((equal? frame-attribute (normalize "none")) #f)
(else #f))
calc-table-after-row-border
#f)
before-column-border: (if (cond
((equal? frame-attribute (normalize "all")) #t)
((equal? frame-attribute (normalize "sides")) #t)
((equal? frame-attribute (normalize "top")) #f)
((equal? frame-attribute (normalize "bottom")) #f)
((equal? frame-attribute (normalize "topbot")) #f)
((equal? frame-attribute (normalize "none")) #f)
(else #f))
calc-table-before-column-border
#f)
after-column-border: (if (cond
((equal? frame-attribute (normalize "all")) #t)
((equal? frame-attribute (normalize "sides")) #t)
((equal? frame-attribute (normalize "top")) #f)
((equal? frame-attribute (normalize "bottom")) #f)
((equal? frame-attribute (normalize "topbot")) #f)
((equal? frame-attribute (normalize "none")) #f)
(else #f))
calc-table-after-column-border
#f)
display-alignment: %cals-display-align%
(make table-part
content-map: '((thead header)
(tbody #f)
(tfoot footer))
($process-colspecs$ (current-node))
(process-children)
(make-table-endnotes)))))
(element colspec
;; now handled by $process-colspecs$ at the top of each tgroup...
(empty-sosofo))
(element spanspec
(empty-sosofo))
(element thead
($process-table-body$ (current-node)))
(element tfoot
($process-table-body$ (current-node)))
(element tbody
($process-table-body$ (current-node)))
(element row
(empty-sosofo)) ;; this should never happen, they're processed explicitly
(element entry
(empty-sosofo)) ;; this should never happen, they're processed explicitly
;; ======================================================================
;; Functions that handle processing of table bodies, rows, and cells
(define ($process-colspecs$ tgroup)
(let* ((cols (string->number (attribute-string (normalize "cols")))))
(let loop ((colnum 1))
(if (> colnum cols)
(empty-sosofo)
(make sequence
(let ((colspec (find-colspec-by-number colnum)))
(if (node-list-empty? colspec)
(make table-column
column-number: colnum
width: (colwidth-unit "1*"))
($process-colspec$ colspec colnum)))
(loop (+ colnum 1)))))))
(define ($process-colspec$ colspec colnum)
(let* ((colwidth (if (attribute-string (normalize "colwidth") colspec)
(attribute-string (normalize "colwidth") colspec)
"1*")))
(make table-column
column-number: colnum
width: (colwidth-unit colwidth))))
(define ($process-table-body$ body)
(let* ((tgroup (ancestor (normalize "tgroup") body))
(cols (string->number (attribute-string (normalize "cols") tgroup)))
(blabel (cond
((equal? (gi body) (normalize "thead")) 'thead)
((equal? (gi body) (normalize "tbody")) 'tbody)
((equal? (gi body) (normalize "tfoot")) 'tfoot))))
(make sequence
label: blabel
(let loop ((rows (select-elements (children body) (normalize "row")))
(overhang (constant-list 0 cols)))
(if (node-list-empty? rows)
(empty-sosofo)
(make sequence
($process-row$ (node-list-first rows) overhang)
(loop (node-list-rest rows)
(update-overhang (node-list-first rows) overhang))))))))
(define ($process-row$ row overhang)
(let* ((tgroup (ancestor (normalize "tgroup") row))
(maxcol (string->number (attribute-string
(normalize "cols") tgroup)))
(lastentry (node-list-last (node-list-filter-out-pis
(children row))))
(table (parent tgroup)))
;; there's no point calculating the row or colsep here, each cell
;; specifies it which overrides anything we might say here...
(make table-row
(let loop ((cells (node-list-filter-out-pis (children row)))
(prevcell (empty-node-list)))
(if (node-list-empty? cells)
(empty-sosofo)
(make sequence
($process-cell$ (node-list-first cells) prevcell row overhang)
(loop (node-list-rest cells) (node-list-first cells)))))
;; add any necessary empty cells to the end of the row
(let loop ((colnum (+ (cell-column-number lastentry overhang)
(hspan lastentry))))
(if (> colnum maxcol)
(empty-sosofo)
(make sequence
($process-empty-cell$ colnum row)
(loop (+ colnum 1))))))))
(define ($process-cell$ entry preventry row overhang)
(let* ((colnum (cell-column-number entry overhang))
(lastcellcolumn (if (node-list-empty? preventry)
0
(- (+ (cell-column-number preventry overhang)
(hspan preventry))
1)))
(lastcolnum (if (> lastcellcolumn 0)
(overhang-skip overhang lastcellcolumn)
0))
(font-name (if (have-ancestor? (normalize "thead") entry)
%title-font-family%
%body-font-family%))
(weight (if (have-ancestor? (normalize "thead") entry)
'bold
'medium))
(align (cell-align entry colnum)))
(make sequence
;; This is a little bit complicated. We want to output empty cells
;; to skip over missing data. We start count at the column number
;; arrived at by adding 1 to the column number of the previous entry
;; and skipping over any MOREROWS overhanging entrys. Then for each
;; iteration, we add 1 and skip over any overhanging entrys.
(let loop ((count (overhang-skip overhang (+ lastcolnum 1))))
(if (>= count colnum)
(empty-sosofo)
(make sequence
($process-empty-cell$ count row)
(loop (overhang-skip overhang (+ count 1))))))
;; Now we've output empty cells for any missing entries, so we
;; are ready to output the cell for this entry...
(make table-cell
column-number: colnum
n-columns-spanned: (hspan entry)
n-rows-spanned: (vspan entry)
cell-row-alignment: (cell-valign entry colnum)
cell-after-column-border: (if (cell-colsep entry colnum)
calc-table-cell-after-column-border
#f)
cell-after-row-border: (if (cell-rowsep entry colnum)
(if (last-sibling? (parent entry))
calc-table-head-body-border
calc-table-cell-after-row-border)
#f)
cell-before-row-margin: %cals-cell-before-row-margin%
cell-after-row-margin: %cals-cell-after-row-margin%
cell-before-column-margin: %cals-cell-before-column-margin%
cell-after-column-margin: %cals-cell-after-column-margin%
;; If there is some additional indentation (because we're in a list,
;; for example) make sure that gets passed along, but don't add
;; the normal body-start-indent.
start-indent: (+ (- (inherited-start-indent) %body-start-indent%)
%cals-cell-content-start-indent%)
end-indent: %cals-cell-content-end-indent%
(if (equal? (gi entry) (normalize "entrytbl"))
(make paragraph
(literal "ENTRYTBL not supported."))
(make paragraph
font-family-name: font-name
font-weight: weight
quadding: align
(process-node-list (children entry))))))))
(define (empty-cell-colsep colnum row)
(let* ((tgroup (ancestor (normalize "tgroup") row))
(table (parent tgroup))
(calscolsep
(if (tgroup-colsep tgroup)
(tgroup-colsep tgroup)
(if (attribute-string (normalize "colsep") table)
(attribute-string (normalize "colsep") table)
(if ($cals-colsep-default$ row)
"1"
"0")))))
(> (string->number calscolsep) 0)))
;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (cell-colsep cell colnum)
(let* ((entry (ancestor-member cell (list (normalize "entry") (normalize "entrytbl"))))
(spanname (attribute-string (normalize "spanname") entry))
(tgroup (find-tgroup entry))
(table (parent tgroup))
(calscolsep
(if (attribute-string (normalize "colsep") entry)
(attribute-string (normalize "colsep") entry)
(if (and spanname
(spanspec-colsep (find-spanspec spanname)))
(spanspec-colsep (find-spanspec spanname))
(if (colspec-colsep (find-colspec-by-number colnum))
(colspec-colsep (find-colspec-by-number colnum))
(if (tgroup-colsep tgroup)
(tgroup-colsep tgroup)
(if (attribute-string (normalize "colsep") table)
(attribute-string (normalize "colsep") table)
(if ($cals-colsep-default$ cell)
"1"
"0"))))))))
(> (string->number calscolsep) 0)))
(define (cell-rowsep cell colnum)
(let* ((entry (ancestor-member cell (list (normalize "entry")
(normalize "entrytbl"))))
(spanname (attribute-string (normalize "spanname") entry))
(row (ancestor (normalize "row") entry))
(tgroup (find-tgroup entry))
(table (parent tgroup))
(calsrowsep
(if (attribute-string (normalize "rowsep") entry)
(attribute-string (normalize "rowsep") entry)
(if (and spanname (spanspec-rowsep (find-spanspec spanname)))
(spanspec-rowsep (find-spanspec spanname))
(if (colspec-rowsep (find-colspec-by-number colnum))
(colspec-rowsep (find-colspec-by-number colnum))
(if (attribute-string (normalize "rowsep") row)
(attribute-string (normalize "rowsep") row)
(if (tgroup-rowsep tgroup)
(tgroup-rowsep tgroup)
(if (attribute-string (normalize "rowsep") table)
(attribute-string (normalize "rowsep") table)
(if ($cals-rowsep-default$ cell)
"1"
"0")))))))))
(> (string->number calsrowsep) 0)))
(define (empty-cell-rowsep colnum row)
(let* ((tgroup (ancestor (normalize "tgroup") row))
(table (parent tgroup))
(calsrowsep
(if (attribute-string (normalize "rowsep") row)
(attribute-string (normalize "rowsep") row)
(if (tgroup-rowsep tgroup)
(tgroup-rowsep tgroup)
(if (attribute-string (normalize "rowsep") table)
(attribute-string (normalize "rowsep") table)
(if ($cals-rowsep-default$ row)
"1"
"0"))))))
(> (string->number calsrowsep) 0)))
;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define ($process-empty-cell$ colnum row)
(make table-cell
column-number: colnum
n-columns-spanned: 1
n-rows-spanned: 1
cell-after-column-border: (if (empty-cell-colsep colnum row)
calc-table-cell-after-column-border
#f)
cell-after-row-border: (if (empty-cell-rowsep colnum row)
(if (last-sibling? row)
calc-table-head-body-border
calc-table-cell-after-row-border)
#f)
cell-before-row-margin: %cals-cell-before-row-margin%
cell-after-row-margin: %cals-cell-after-row-margin%
cell-before-column-margin: %cals-cell-before-column-margin%
cell-after-column-margin: %cals-cell-after-column-margin%
start-indent: %cals-cell-content-start-indent%
end-indent: %cals-cell-content-end-indent%
(empty-sosofo)))
;; EOF