;; $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