;; $Id$
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://nwalsh.com/docbook/dsssl/
;;
;; This file contains table functions common to both print and HTML
;; versions of the DocBook stylesheets.
;;

;; If **ANY** change is made to this file, you _MUST_ alter the
;; following definition:

(define %docbook-common-table-version%
  "Modular DocBook Stylesheet Common Table Functions")

;; == Table Support =====================================================

;; ----------------------------------------------------------------------
;; Functions for finding/retrieving table attributes

(define (tgroup-align tgroup)
  (attribute-string (normalize "align") tgroup))

(define (tgroup-colsep tgroup)
  (attribute-string (normalize "colsep") tgroup))

(define (tgroup-rowsep tgroup)
  (attribute-string (normalize "rowsep") tgroup))

;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (find-tgroup #!optional (nd (current-node)))
  ;; for our purposes, an entrytbl functions as a tgroup.
  ;; ENTRYTBL IS ONLY SUPPORTED IN THE HTML BACKEND!!!
  (if (or (equal? (gi nd) (normalize "tgroup"))
	  (equal? (gi nd) (normalize "entrytbl")))
      nd
      (if (node-list-empty? (ancestor (normalize "entrytbl") nd))
	  (ancestor (normalize "tgroup") nd)
	  (ancestor (normalize "entrytbl") nd))))

(define (find-colspec colname)
  (let* ((tgroup (find-tgroup))
	 (colspecs (select-elements (descendants tgroup)
				    (normalize "colspec"))))
    (let loop ((nl colspecs))
	(if (node-list-empty? nl)
	    ;; we've run out of places to look, stop looking...
	    (error (string-append "Could not find COLSPEC named " colname))
	    (if (equal? colname
			(attribute-string (normalize "colname") 
					  (node-list-first nl)))
		(node-list-first nl)
		(loop (node-list-rest nl)))))))

(define (find-colspec-by-number colnum)
  (let* ((tgroup (find-tgroup))
	 (colspecs (select-elements (children tgroup) (normalize "colspec"))))
    (let loop ((nl colspecs))
      (if (node-list-empty? nl)
	  ;; we've run out of places to look, stop looking...
	  (empty-node-list)
	  (if (equal? (colspec-colnum (node-list-first nl)) colnum)
	      (node-list-first nl)
	      (loop (node-list-rest nl)))))))

(define (colspec-align colspec)
  (attribute-string (normalize "align") colspec))

(define (colspec-char colspec)
  (attribute-string (normalize "char") colspec))

(define (colspec-charoff colspec)
  (let ((charoff (attribute-string (normalize "charoff") colspec)))
    (if charoff
	(string->number charoff)
	#f)))

(define (colspec-colnum colspec)
  ;; returns the column number of the associated colspec...which is 
  ;; either the value of COLNUM or obtained by counting
  (let* ((tgroup (find-tgroup colspec))
	 (colspecs (select-elements (children tgroup) (normalize "colspec"))))
    (if (attribute-string (normalize "colnum") colspec)
	(string->number (attribute-string (normalize "colnum") colspec))
	(let loop ((nl colspecs) (curcol 1))
	  (let ((colnum (attribute-string (normalize "colnum") (node-list-first nl))))
	    (if (node-list=? (node-list-first nl) colspec)
		curcol
		(if colnum
		    (loop (node-list-rest nl) (+ (string->number colnum) 1))
		    (loop (node-list-rest nl) (+ curcol 1)))))))))

(define (colspec-colname colspec)
  (attribute-string (normalize "colname") colspec))

(define (colspec-colsep colspec)
  (attribute-string (normalize "colsep") colspec))

(define (colspec-colwidth colspec)
  (if (attribute-string (normalize "colwidth") colspec)
      (attribute-string (normalize "colwidth") colspec)
      "1*"))

(define (colspec-rowsep colspec)
  (attribute-string (normalize "rowsep") colspec))

;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (find-spanspec spanname)
  (let* ((tgroup (find-tgroup))
	 (spanspecs (select-elements (descendants tgroup) 
				     (normalize (normalize "spanspec")))))
    (let loop ((nl spanspecs))
      (if (node-list-empty? nl)
	  (error (string-append "Could not find SPANSPEC named " spanname))
	  (if (equal? spanname 
		      (attribute-string (normalize "spanname")
					(node-list-first nl)))
	      (node-list-first nl)
	      (loop (node-list-rest nl)))))))

(define (spanspec-align spanspec)
  (attribute-string (normalize "align") spanspec))

(define (spanspec-char spanspec)
  (attribute-string (normalize "char") spanspec))

(define (spanspec-charoff spanspec)
  (let ((charoff (attribute-string (normalize "charoff") spanspec)))
    (if charoff
	(string->number charoff)
	#f)))

(define (spanspec-colsep spanspec)
  (attribute-string (normalize "colsep") spanspec))

(define (spanspec-nameend spanspec)
  (attribute-string (normalize "nameend") spanspec))

(define (spanspec-namest spanspec)
  (attribute-string (normalize "namest") spanspec))

(define (spanspec-rowsep spanspec)
  (attribute-string (normalize "rowsep") spanspec))

(define (spanspec-spanname spanspec)
  (attribute-string (normalize "spanname") spanspec))

;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Calculate spans

(define (hspan entry)
  ;; Returns the horizontal span of an entry
  (let* ((spanname (attribute-string (normalize "spanname") entry))
	 (namest   (if spanname
		       (spanspec-namest (find-spanspec spanname))
		       (attribute-string (normalize "namest") entry)))
	 (nameend  (if spanname
		       (spanspec-nameend (find-spanspec spanname))
		       (attribute-string (normalize "nameend") entry)))
	 (colst    (if namest
		       (colspec-colnum (find-colspec namest))
		       #f))
	 (colend   (if nameend
		       (colspec-colnum (find-colspec nameend))
		       #f)))
    (if (and namest nameend)
	(+ (- colend colst) 1)
	1)))

(define (vspan entry)
  ;; Returns the vertical span of an entry.  Note that this is one more
  ;; than the specified MOREROWS attribute.
  (let* ((morerows (attribute-string (normalize "morerows") entry)))
    (if morerows
	(+ (string->number morerows) 1)
	1)))

;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Update the "overhang" list

(define (adjust-overhang overhang oldoverhang entry)
  (let* ((colst    (cell-column-number entry oldoverhang))
	 (span     (hspan entry)))
    (if (> (vspan entry) 1)
	(list-put overhang colst (- (vspan entry) 1) span)
	overhang)))

(define (overhang-skip overhang startcol)
  (if (> startcol (length overhang))
      ;; this is a _broken_ table.  should I output a debug message!?
      startcol
      (let loop ((overtail (list-tail overhang (- startcol 1))) (col startcol))
	(if (null? overtail)
	    col
	    (if (equal? (car overtail) 0)
		col
		(loop (cdr overtail) (+ col 1)))))))

(define (update-overhang row oldoverhang)
  (let loop ((overhang (decrement-list-members oldoverhang))
	     (entries  (node-list-filter-out-pis (children row))))
    (if (node-list-empty? entries)
	overhang
	(loop (adjust-overhang overhang oldoverhang 
			       (node-list-first entries))
	      (node-list-rest entries)))))

;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Calculate information about cells

(define (cell-prev-cell entry)
  ;; Return the cell which precedes entry in the current row.
  (let loop ((nd (ipreced entry)))
    (if (node-list-empty? nd)
	nd
	(if (equal? (node-property 'class-name nd) 'element)
	    nd
	    (loop (ipreced nd))))))

(define (cell-column-number entry overhang)
  (let* ((entry     (ancestor-member entry (list (normalize "entry") (normalize "entrytbl"))))
	 (row       (ancestor (normalize "row") entry))
	 (preventry (cell-prev-cell entry))
	 (prevspan  (if (node-list-empty? preventry) 1 (hspan preventry)))
	 (colname   (attribute-string (normalize "colname") entry))
	 (namest    (attribute-string (normalize "namest") entry))
	 (nameend   (attribute-string (normalize "nameend") entry))
	 (spanname  (attribute-string (normalize "spanname") entry)))
    (if colname
	(colspec-colnum (find-colspec colname))
	(if spanname
	    (colspec-colnum (find-colspec 
			     (spanspec-namest (find-spanspec spanname))))
	    (if namest
		(colspec-colnum (find-colspec namest))
		(if (node-list-empty? preventry)
		    (overhang-skip overhang 1)
		    (overhang-skip overhang 
				   (+ (cell-column-number preventry overhang) 
				   prevspan))))))))

;; ======================================================================