]> , except for the right rule, which will be present ;; if a cell sets cell-after-column-border. This will be fixed; ;; check this stylesheet later. ;; width and height set directly on table cells is not supported. ;; p: temporary; delete when merging into a full HTML stylesheet. (element p (let ((cellpadding (let ((cp-attr (inherited-attribute-string (norm "cellpadding") (current-node)))) (if cp-attr (* (string->number cp-attr) 1pt) 0pt)))) (make paragraph start-indent: cellpadding end-indent: cellpadding space-before: cellpadding space-after: cellpadding))) ;; (find-table-width) analyzes the specified table node to find its ;; width. This is used by the table itself and by child column ;; specifications. (define (find-table-width #!optional (snl (current-node))) (let ((width (attribute-string (norm "width") snl))) (if width ;; is the width in percentage? (if (equal? (string-ref width (- (string-length width) 1)) #\%) ;; yes - multiply by display-size (* (display-size) (/ (string->number (substring width 0 (- (string-length width) 1))) 100)) ;; no - assume it's pixels (* (string->number width) 1pt)) ;; no width; use available space (display-size)))) ;; (get-column-number) analyzes the previous cells in a table for ;; vertical spans in order to determine the proper location for the ;; current cell. row-num-array is an array of i integers, where i is ;; the number of cells in a row (as far as is known), and where the ;; (i-1)th element is the number of rows filled in that column so ;; far. Both rows and columns are counted from 0. (define (get-column-number) ;; Loop over the rows of the table part. (let row-loop ((rows (children (origin (ancestor (norm "tr") (current-node))))) (row-num 0) (row-num-array '())) ;; Loop over the cells in each column, building the array. ;; Returns a two-member list; the first is the column-number of ;; (current-node), if it was in the row, or -1 if it wasn't. The ;; second is the row-num-array as modified by the row (or the ;; empty list, if (current-node) was found. (let ((new-info (let cell-loop ((cells (children (node-list-first rows))) (col-num 0) (col-span 0) (cell-row-array row-num-array)) (if (node-list-empty? cells) ;; we finished the row (list -1 cell-row-array) ;; set some useful values (let ((array-length (length cell-row-array)) (row-dest (+ row-num (- (string->number (attribute-string (norm "rowspan") (node-list-first cells))) 1))) (colspan (string->number (attribute-string (norm "colspan") (node-list-first cells))))) (if (node-list=? (node-list-first cells) (current-node)) ;; this is us! (if (and (> array-length col-num) (>= (list-ref cell-row-array col-num) row-num)) ;; but we don't fit here - keep ;; trying (cell-loop cells (+ col-num 1) 0 cell-row-array) ;; this is our home - return the ;; column-number. (list col-num '())) ;; this isn't us yet, so cell-loop ;; again with the adjusted array. (cell-loop (if (or (> col-span 1) (and (= col-span 0) (> colspan 1)) (and (> array-length col-num) (>= (list-ref cell-row-array col-num) row-num))) ;; we're in a span ;; that's not done yet, ;; or we don't fit ;; here, so don't knock ;; off the lead cell cells ;; pass the rest of the ;; cells back to the ;; loop (node-list-rest cells)) ;; incr the col-num (+ col-num 1) ;; note if we're in a span, ;; and how many columns are ;; left (cond ((> col-span 0) (- col-span 1)) ((and (> colspan 1) (or (<= array-length col-num) (< (list-ref cell-row-array col-num) row-num))) (- colspan 1)) (else 0)) (if (> col-span 0) ;; we're in a span, so ;; place this cell ;; whether or not it ;; overlaps something; ;; the markup was in ;; violation anyway (if (<= array-length col-num) (append cell-row-array (list row-dest)) (append (reverse (list-tail (reverse cell-row-array) (- array-length col-num))) (list row-dest) (list-tail cell-row-array (+ col-num 1)))) ;; we're not in a span, ;; so check the array (if (<= array-length col-num) ;; there wasn't an ;; entry for this ;; column yet (append cell-row-array (list row-dest)) ;; do we fit in ;; this column? (if (>= (list-ref cell-row-array col-num) row-num) ;; no, so keep ;; the array ;; unchanged cell-row-array ;; yes, so ;; replace this ;; column's ;; entry with a ;; new number (append (reverse (list-tail (reverse cell-row-array) (- array-length col-num))) (list row-dest) (list-tail cell-row-array (+ col-num 1))))))))))))) ;; what did the row analysis find? (if (= (car new-info) -1) ;; the (current-node) was not in the row, so row-loop again ;; with the rest of the rows. (row-loop (node-list-rest rows) (+ row-num 1) (car (cdr new-info))) ;; the (current-node) was found; increment the 0-based index ;; for the column-number (+ (car new-info) 1))))) ;; converts two-digit hex string to decimal fraction where 0->0 and ;; 255->1 (define (hex-s-to-dec-frac str) (/ (string->number str 16) 255)) ;; Analyze the table or colgroup. Create table-columns for each col ;; element, or for each column implied by span attribute. (define (make-columns) (let col-loop ((colspecs (get-children-by-type (list (norm "col") (norm "colgroup")))) (columns (if (equal? (gi (current-node)) (norm "colgroup")) (attribute-string (norm "span") (current-node)) #f)) (rules (inherited-attribute-string (norm "rules"))) (cols-so-far 0)) (if (node-list-empty? colspecs) ;; if the colspecs are depleted, does the attribute imply that ;; we need more table-columns? (if (or (not columns) (<= (string->number columns) cols-so-far)) (empty-sosofo) ;; if so, make them; inherit qualities from colgroup if ;; there is one (sosofo-append (make table-column width: (if (equal? (gi (current-node)) (norm "colgroup")) (let ((cgwidth (attribute-string (norm "width") (current-node)))) (if cgwidth ;; is the width in ;; percentage? (if (equal? (string-ref cgwidth (- (string-length cgwidth) 1)) #\%) ;; yes - ;; multiply by ;; table width (* (find-table-width (ancestor (norm "table"))) (/ (string->number (substring cgwidth 0 (- (string-length cgwidth) 1))) 100)) ;; no - assume ;; it's pixels (* (string->number cgwidth) 1pt)) (table-unit 1))) (table-unit 1)) cell-before-column-border: (if (and (equal? (gi (current-node)) (norm "colgroup")) (= cols-so-far 0) (equal? rules (norm "groups"))) #t (inherited-cell-before-column-border)) cell-after-column-border: (if (and (equal? (gi (current-node)) (norm "colgroup")) (= cols-so-far (- (string->number columns) 1))) #t (inherited-cell-after-column-border)) quadding: (if (equal? (gi (current-node)) (norm "colgroup")) (let ((align (attribute-string (norm "align") (current-node)))) (cond ((equal? align (norm "left")) 'start) ((equal? align (norm "center")) 'center) ((member align (list (norm "right") (norm "char"))) 'end) ((equal? align (norm "justify")) 'justify) (else (inherited-quadding)))) (inherited-quadding)) cell-row-alignment: (let ((valign (attribute-string (norm "valign") (current-node)))) (cond ((member valign (list (norm "top") (norm "baseline"))) 'start) ((equal? valign (norm "middle")) 'center) ((equal? valign (norm "bottom")) 'end) ((not valign) (inherited-cell-row-alignment))))) (col-loop (empty-node-list) columns rules (+ cols-so-far 1)))) (sosofo-append (process-node-list (node-list-first colspecs)) (col-loop (node-list-rest colspecs) columns rules (+ cols-so-far 1)))))) ;; Caption for a table, processed first whether it occurs before or ;; after the table matter. (mode table-caption (element caption (make paragraph font-weight: 'bold quadding: 'center space-before: (inherited-line-spacing) keep-with-next?: #t (with-mode #f (process-children-trim))))) ;; Caption already processed in table-caption mode. (element caption (empty-sosofo)) ;; Create a table-column based on col element's inherited attributes. (element col (let ((rules (inherited-attribute-string (norm "rules")))) (make table-column n-columns-spanned: (string->number (attribute-string (norm "span") (current-node))) ;; Only inherit the width from colgroup, not from ;; table. width: (let ((colwidth (let ((width (attribute-string (norm "width") (current-node)))) (if width width (attribute-string (norm "width") (ancestor (norm "colgroup") (current-node))))))) (if colwidth ;; is the width in percentage? (if (equal? (string-ref colwidth (- (string-length colwidth) 1)) #\%) ;; yes - multiply by table width (* (find-table-width (ancestor (norm "table"))) (/ (string->number (substring colwidth 0 (- (string-length colwidth) 1))) 100)) ;; no - assume it's pixels (* (string->number colwidth) 1pt)) (table-unit 1))) ;; need rules if rules="groups" cell-before-column-border: (if (and (equal? rules (norm "groups")) (first-sibling?)) #t (inherited-cell-before-column-border)) cell-after-column-border: (if (and (equal? rules (norm "groups")) (last-sibling?) (or (not (attribute-string (norm "span") (ancestor (norm "colgroup")))) (equal? (string->number (attribute-string (norm "span") (ancestor (norm "colgroup")))) (child-number (current-node))))) #t (inherited-cell-after-column-border)) ;; align attribute should only come from self or ;; colgroup. quadding: (let* ((align (attribute-string (norm "align") (current-node))) (str (if align align (attribute-string (norm "align") (ancestor (norm "colgroup") (current-node)))))) (cond ((equal? str (norm "left")) 'start) ((equal? str (norm "center")) 'center) ((member str (list (norm "right") (norm "char"))) 'end) ((equal? str (norm "justify")) 'justify) (else (inherited-quadding)))) ;; valign should also only come from colgroup, but no ;; other element uses it so ;; (inherited-attribute-string) is safe. cell-row-alignment: (let ((valign (inherited-attribute-string (norm "valign") (current-node)))) (cond ((member valign (list (norm "top") (norm "baseline"))) 'start) ((equal? valign (norm "middle")) 'center) ((equal? valign (norm "bottom")) 'end) ((not valign) (inherited-cell-row-alignment))))))) ;; Group of columns; process its children. (element colgroup (make-columns)) ;; Create the caption, then handle the content. (element table (sosofo-append (with-mode table-caption (process-first-descendant (norm "caption"))) (make table ;; inherit the width from flowtree ;; parents if not specified here. table-width: (find-table-width) ;; border="0" overrides any other ;; border-creating attributes. before-row-border: (if (equal? (attribute-string (norm "border") (current-node)) "0") #f (if (member (attribute-string (norm "frame") (current-node)) (list (norm "void") (norm "below") (norm "lhs") (norm "rhs") (norm "vsides"))) #f #t)) after-row-border: (if (equal? (attribute-string (norm "border") (current-node)) "0") #f (if (member (attribute-string (norm "frame") (current-node)) (list (norm "void") (norm "above") (norm "lhs") (norm "rhs") (norm "vsides"))) #f #t)) before-column-border: (if (equal? (attribute-string (norm "border") (current-node)) "0") #f (if (member (attribute-string (norm "frame") (current-node)) (list (norm "void") (norm "above") (norm "below") (norm "hsides") (norm "rhs"))) #f #t)) after-column-border: (if (equal? (attribute-string (norm "border") (current-node)) "0") #f (if (member (attribute-string (norm "frame") (current-node)) (list (norm "void") (norm "above") (norm "below") (norm "hsides") (norm "lhs"))) #f #t)) ;; Keep the table with its caption. keep-with-previous?: (if (node-list-empty? (get-children-by-type (list (norm "caption")))) #f #t) ;; Make a content-map to place the table ;; parts correctly. (make table-part content-map: '((thead header) (tbody #f) (tfoot footer)) (make-columns) (process-first-descendant (norm "thead")) (process-first-descendant (norm "tfoot")) (process-matching-children (norm "tbody")))))) ;; This will go in the main port of the table-part flow object. (element tbody (make sequence label: 'tbody quadding: (let ((align (attribute-string (norm "align") (current-node)))) (cond ((equal? align (norm "left")) 'start) ((equal? align (norm "center")) 'center) ((member align (list (norm "right") (norm "char"))) 'end) ((equal? align (norm "justify")) 'justify) (else (inherited-quadding)))) cell-row-alignment: (let ((valign (attribute-string (norm "valign") (current-node)))) (cond ((member valign (list (norm "top") (norm "baseline"))) 'start) ((equal? valign (norm "middle")) 'center) ((equal? valign (norm "bottom")) 'end) (else (inherited-cell-row-alignment)))))) ;; A table cell. (element td ;; save some useful values (let ((cellspacing (let ((cs-attr (inherited-attribute-string (norm "cellspacing") (current-node)))) (if cs-attr (* (string->number cs-attr) 1pt) 0pt))) (bgcolor (attribute-string (norm "bgcolor") (current-node))) (border (inherited-attribute-string (norm "border") (current-node))) (rules (inherited-attribute-string (norm "rules") (current-node))) (col-num (get-column-number))) (make table-cell column-number: col-num n-columns-spanned: (string->number (attribute-string (norm "colspan") (current-node))) n-rows-spanned: (string->number (attribute-string (norm "rowspan") (current-node))) cell-before-row-margin: cellspacing cell-after-row-margin: cellspacing cell-before-column-margin: cellspacing cell-after-column-margin: cellspacing cell-row-alignment: (let ((valign (inherited-attribute-string (norm "valign") (current-node)))) (cond ((member valign (list (norm "top") (norm "baseline"))) 'start) ((equal? valign (norm "middle")) 'center) ((equal? valign (norm "bottom")) 'end) ((not valign) (inherited-cell-row-alignment)))) cell-background?: (if bgcolor #t #f) background-color: (if bgcolor (color (color-space "ISO/IEC 10179:1996//Color-Space Family::Device RGB") (hex-s-to-dec-frac (substring bgcolor 1 3)) (hex-s-to-dec-frac (substring bgcolor 3 5)) (hex-s-to-dec-frac (substring bgcolor 5 7))) #f) ;; border="0" overrides any other ruling information; ;; frame controls outermost rules cell-before-row-border: (cond ((equal? border "0") #f) ((and (not (node-list-empty? (ancestor (norm "thead")))) (first-sibling? (ancestor (norm "tr")))) #f) ((and (node-list-empty? (get-children-by-type (list (norm "thead")) (ancestor (norm "table")))) (not (node-list-empty? (ancestor (norm "tbody")))) (first-sibling? (ancestor (norm "tbody"))) (first-sibling? (ancestor (norm "tr")))) #f) ((member rules (list (norm "none") (norm "cols"))) #f) ((equal? rules (norm "groups")) (first-sibling? (ancestor (norm "tr")))) (else #t)) cell-after-row-border: (cond ((equal? border "0") #f) ((and (not (node-list-empty? (ancestor (norm "tfoot")))) (last-sibling? (ancestor (norm "tr")))) #f) ((and (node-list-empty? (get-children-by-type (list (norm "tfoot")) (ancestor (norm "table")))) (not (node-list-empty? (ancestor (norm "tbody")))) (last-sibling? (ancestor (norm "tbody"))) (last-sibling? (ancestor (norm "tr")))) #f) ((member rules (list (norm "none") (norm "cols"))) #f) ((equal? rules (norm "groups")) (last-sibling? (ancestor (norm "tr")))) (else #t)) cell-before-column-border: (cond ((equal? border "0") #f) ((equal? col-num 1) #f) ((member rules (list (norm "none") (norm "rows"))) #f) ((equal? rules (norm "groups")) (inherited-cell-before-column-border)) (else #t)) cell-after-column-border: (cond ((equal? border "0") #f) ((member rules (list (norm "none") (norm "rows"))) #f) ((equal? rules (norm "groups")) (inherited-cell-after-column-border)) (else #t)) quadding: (let ((align (attribute-string (norm "align") (current-node)))) (cond ((equal? align (norm "left")) 'start) ((equal? align (norm "center")) 'center) ((member align (list (norm "right") (norm "char"))) 'end) ((equal? align (norm "justify")) 'justify) (else (inherited-quadding)))) (if (node-list-empty? (node-list-filter (lambda (snl) (equal? (node-property 'class-name snl) 'element)) (children (current-node)))) (let ((cellpadding (let ((cp-attr (inherited-attribute-string (norm "cellpadding") (current-node)))) (if cp-attr (* (string->number cp-attr) 1pt) 0pt)))) (make paragraph start-indent: cellpadding end-indent: cellpadding space-before: cellpadding space-after: cellpadding (process-children))) (process-children))))) ;; This should go in the footer port of the table-part. (element tfoot (make sequence label: 'tfoot quadding: (let ((align (attribute-string (norm "align") (current-node)))) (cond ((equal? align (norm "left")) 'start) ((equal? align (norm "center")) 'center) ((member align (list (norm "right") (norm "char"))) 'end) ((equal? align (norm "justify")) 'justify) (else (inherited-quadding)))) cell-row-alignment: (let ((valign (attribute-string (norm "valign") (current-node)))) (cond ((member valign (list (norm "top") (norm "baseline"))) 'start) ((equal? valign (norm "middle")) 'center) ((equal? valign (norm "bottom")) 'end) (else (inherited-cell-row-alignment)))))) ;; Identical to td except bold. (element th ;; save some useful values (let ((cellspacing (let ((cs-attr (inherited-attribute-string (norm "cellspacing") (current-node)))) (if cs-attr (* (string->number cs-attr) 1pt) 0pt))) (bgcolor (attribute-string (norm "bgcolor") (current-node))) (border (inherited-attribute-string (norm "border") (current-node))) (rules (inherited-attribute-string (norm "rules") (current-node)))) (make table-cell font-weight: 'bold column-number: (get-column-number) n-columns-spanned: (string->number (attribute-string (norm "colspan") (current-node))) n-rows-spanned: (string->number (attribute-string (norm "rowspan") (current-node))) cell-before-row-margin: cellspacing cell-after-row-margin: cellspacing cell-before-column-margin: cellspacing cell-after-column-margin: cellspacing cell-row-alignment: (let ((valign (inherited-attribute-string (norm "valign") (current-node)))) (cond ((member valign (list (norm "top") (norm "baseline"))) 'start) ((equal? valign (norm "middle")) 'center) ((equal? valign (norm "bottom")) 'end) ((not valign) (inherited-cell-row-alignment)))) cell-background?: (if bgcolor #t #f) background-color: (if bgcolor (color (color-space "ISO/IEC 10179:1996//Color-Space Family::Device RGB") (hex-s-to-dec-frac (substring bgcolor 1 3)) (hex-s-to-dec-frac (substring bgcolor 3 5)) (hex-s-to-dec-frac (substring bgcolor 5 7))) #f) ;; border="0" overrides any other ruling information. cell-before-row-border: (if (equal? border "0") #f (cond ((member rules (list (norm "none") (norm "cols"))) #f) ((equal? rules (norm "groups")) (first-sibling? (ancestor (norm "tr")))) (else #t))) cell-after-row-border: (if (equal? border "0") #f (cond ((member rules (list (norm "NONE") (norm "cols"))) #f) ((equal? rules (norm "groups")) (last-sibling? (ancestor (norm "tr")))) (else #t))) cell-before-column-border: (if (equal? border "0") #f (cond ((member rules (list (norm "none") (norm "rows"))) #f) ((equal? rules (norm "groups")) (inherited-cell-before-column-border)) (else #t))) cell-after-column-border: (if (equal? border "0") #f (cond ((member rules (list (norm "none") (norm "rows"))) #f) ((equal? rules (norm "groups")) (inherited-cell-after-column-border)) (else #t))) quadding: (let ((align (attribute-string (norm "align") (current-node)))) (cond ((equal? align (norm "left")) 'start) ((equal? align (norm "center")) 'center) ((member align (list (norm "right") (norm "char"))) 'end) ((equal? align (norm "justify")) 'justify) (else (inherited-quadding)))) (if (node-list-empty? (node-list-filter (lambda (snl) (equal? (node-property 'class-name snl) 'element)) (children (current-node)))) (let ((cellpadding (let ((cp-attr (inherited-attribute-string (norm "cellpadding") (current-node)))) (if cp-attr (* (string->number cp-attr) 1pt) 0pt)))) (make paragraph start-indent: cellpadding end-indent: cellpadding space-before: cellpadding space-after: cellpadding (process-children))) (process-children))))) ;; This goes in the header port of the table-part. (element thead (make sequence label: 'thead quadding: (let ((align (attribute-string (norm "align") (current-node)))) (cond ((equal? align (norm "left")) 'start) ((equal? align (norm "center")) 'center) ((member align (list (norm "right") (norm "char"))) 'end) ((equal? align (norm "justify")) 'justify) (else (inherited-quadding)))) cell-row-alignment: (let ((valign (attribute-string (norm "valign") (current-node)))) (cond ((member valign (list (norm "top") (norm "baseline"))) 'start) ((equal? valign (norm "middle")) 'center) ((equal? valign (norm "bottom")) 'end) (else (inherited-cell-row-alignment)))))) ;; A humble row. (element tr (make table-row quadding: (let ((align (attribute-string (norm "align") (current-node)))) (cond ((equal? align (norm "left")) 'start) ((equal? align (norm "center")) 'center) ((member align (list (norm "right") (norm "char"))) 'end) ((equal? align (norm "justify")) 'justify) (else (inherited-quadding)))) cell-row-alignment: (let ((valign (attribute-string (norm "valign") (current-node)))) (cond ((member valign (list (norm "top") (norm "baseline"))) 'start) ((equal? valign (norm "middle")) 'center) ((equal? valign (norm "bottom")) 'end) (else (inherited-cell-row-alignment)))))) ]]>