aboutsummaryrefslogtreecommitdiff
path: root/src/guile
diff options
context:
space:
mode:
authorLudovic Courtès2008-10-10 00:13:41 +0200
committerLudovic Courtès2008-10-10 00:13:41 +0200
commit90c67b504f0495f15787b81e8325f1d5824e0a41 (patch)
tree7699e21342e70c5e59970afb8732e8622f48a46b /src/guile
parent9aaaf08efd0cccdac8bda6d9a9b58e39609b09c6 (diff)
downloadskribilo-90c67b504f0495f15787b81e8325f1d5824e0a41.tar.gz
skribilo-90c67b504f0495f15787b81e8325f1d5824e0a41.tar.lz
skribilo-90c67b504f0495f15787b81e8325f1d5824e0a41.zip
Import `table.scm' (ASCII tables) from Scribe 1.1a.
Diffstat (limited to 'src/guile')
-rw-r--r--src/guile/skribilo/utils/text-table.scm226
1 files changed, 226 insertions, 0 deletions
diff --git a/src/guile/skribilo/utils/text-table.scm b/src/guile/skribilo/utils/text-table.scm
new file mode 100644
index 0000000..20dbb23
--- /dev/null
+++ b/src/guile/skribilo/utils/text-table.scm
@@ -0,0 +1,226 @@
+;*=====================================================================*/
+;* serrano/prgm/project/scribe/scribetext/table.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Mon Nov 5 06:41:44 2001 */
+;* Last change : Fri Nov 23 11:04:56 2001 (serrano) */
+;* Copyright : 2001 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Table handling */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* The module */
+;*---------------------------------------------------------------------*/
+(module __scribetext_table
+
+ (library scribeapi)
+
+ (import __scribetext_justify)
+
+ (export (table->ascii ::%table ::procedure)))
+
+;*---------------------------------------------------------------------*/
+;* table->ascii ... */
+;*---------------------------------------------------------------------*/
+(define (table->ascii obj scribe->ascii)
+ (with-access::%table obj (width nbcols rows)
+ (let* ((nc::long nbcols)
+ (awidth (-fx (cond
+ ((fixnum? width)
+ width)
+ ((flonum? width)
+ (inexact->exact (* width (justification-width))))
+ (else
+ (justification-width)))
+ ;; remove one characters per columns separation
+ (-fx nc 1)))
+ (colswidth::vector (rows-requested-sizes obj nc awidth))
+ (lcolswidth::pair-nil (vector->list colswidth))
+ (nb-def-cols (length (filter (lambda (s) (= s 0)) lcolswidth)))
+ (defcolwidth (if (= nb-def-cols 0)
+ 0
+ (inexact->exact
+ (/ (- awidth (apply + lcolswidth))
+ nb-def-cols)))))
+ ;; we have computed the requested col sizes and the global size
+ ;; of the table, we now compute the exact col sizes
+ (let loop ((i 0)
+ (sum 0))
+ (if (=fx i nc)
+ ;; we adjust (because of modulo approx) the last column
+ (if (not (=fx sum awidth))
+ (vector-set! colswidth
+ (-fx i 1)
+ (+fx (vector-ref colswidth (-fx i 1))
+ (-fx awidth sum))))
+ (if (= (vector-ref colswidth i) 0)
+ (begin
+ (vector-set! colswidth i defcolwidth)
+ (loop (+fx i 1) (+fx sum defcolwidth)))
+ (loop (+fx i 1) (+fx sum (vector-ref colswidth i))))))
+ ;; at that point colswidth contains the width of each colums.
+ (let ((lcolswidth (vector->list colswidth))
+ (hrows (map (lambda (r)
+ (table-row-format r nc colswidth scribe->ascii))
+ rows)))
+ (let ((vrows (map (lambda (r)
+ (let ((lines (apply max
+ (map (lambda (c)
+ (length (cdr c)))
+ r))))
+ (smallest-map (lambda (c cw)
+ (table-cell-vformat
+ c lines cw))
+ r lcolswidth)))
+ hrows)))
+ ;; we are done, all cells are formated, we can display the
+ ;; whole table now
+ (for-each (lambda (r)
+ (apply for-each
+ (lambda l
+ (for-each output-token l)
+ (output-newline))
+ r))
+ vrows))))))
+
+;*---------------------------------------------------------------------*/
+;* table-row-format ... */
+;*---------------------------------------------------------------------*/
+(define (table-row-format row::%table-row nbcols::int colswidth scribe->ascii)
+ (define (cell-width cnum cspan)
+ (let ((v (do ((i cnum (+fx i 1))
+ (w 0 (+fx w (vector-ref colswidth i))))
+ ((=fx i (+fx cnum cspan)) w))))
+ (+fx v (-fx cspan 1))))
+ (with-access::%table-row row (cells)
+ (let loop ((cells cells)
+ (cnum 0)
+ (res '()))
+ (cond
+ ((pair? cells)
+ (let* ((cell (car cells))
+ (cspan (%table-cell-colspan cell))
+ (cell-width (cell-width cnum cspan)))
+ (loop (cdr cells)
+ (+fx cnum cspan)
+ (cons (table-cell-format cell
+ cell-width
+ scribe->ascii)
+ res))))
+ ((=fx cnum nbcols)
+ (reverse! res))
+ (else
+ (let ((eline (make-string (vector-ref colswidth cnum) #\space)))
+ (loop cells
+ (+fx cnum 1)
+ (cons (cons (instantiate::%table-data
+ (body ""))
+ (list eline)) res))))))))
+
+;*---------------------------------------------------------------------*/
+;* table-cell-format ::table-cell ... */
+;* ------------------------------------------------------------- */
+;* Output a table cell according to its WIDTH. At that time we have */
+;* to ignore the width that is specified in the cell because we */
+;* have processed a global computation of column width. For the */
+;* reason, we ignore the cell COLSPAN. */
+;* ------------------------------------------------------------- */
+;* This is a bit tricky because we can't display the cell as */
+;* we process it. We have to store in data structures the lines */
+;* representing the cell and in a second time, when all the table */
+;* is processed we display the cells. For that reason, we can't */
+;* use WITH-JUSTIFICATION form. */
+;*---------------------------------------------------------------------*/
+(define (table-cell-format obj::%table-cell width scribe->ascii)
+ (with-access::%table-cell obj (align body)
+ (cons obj
+ (let ((fmt (with-justification/noflush
+ (make-justifier width
+ (case align
+ ((left)
+ 'left)
+ ((right)
+ 'right)
+ ((center)
+ 'center)
+ (else
+ (if (not align)
+ 'left
+ (error "table-cell-format"
+ "Illegal horizontal alignment"
+ align)))))
+ (lambda () (scribe->ascii body)))))
+ (if (null? fmt)
+ '("")
+ fmt)))))
+
+;*---------------------------------------------------------------------*/
+;* table-cell-vformat ... */
+;* ------------------------------------------------------------- */
+;* We have formated the table cell horizontally. Now we have to */
+;* consider the VALIGN fields. That is, we complete the cell */
+;* formating with empty blank line around the cell. */
+;*---------------------------------------------------------------------*/
+(define (table-cell-vformat::pair p::pair nblines::int cwidth)
+ (define (make-filler-lines num)
+ (vector->list (make-vector num (make-string cwidth #\Space))))
+ (let* ((cell (car p))
+ (fmt (cdr p))
+ (lfmt (length fmt)))
+ (if (=fx lfmt nblines)
+ fmt
+ (let* ((new (- nblines lfmt))
+ (new/2 (inexact->exact (/ new 2))))
+ (case (%table-cell-valign cell)
+ ((top)
+ (append fmt (make-filler-lines new)))
+ ((bottom)
+ (append (make-filler-lines new) fmt))
+ (else
+ (append (make-filler-lines new/2)
+ fmt
+ (make-filler-lines (- nblines lfmt new/2)))))))))
+
+;*---------------------------------------------------------------------*/
+;* rows-requested-sizes ... */
+;* ------------------------------------------------------------- */
+;* This function scans all the rows of TABLE. It check each */
+;* cells of the rows in order to find out if there is a */
+;* specified width for the column the cell belongs to. */
+;*---------------------------------------------------------------------*/
+(define (rows-requested-sizes table nbcols twidth)
+ (let ((rsizes (make-vector nbcols 0)))
+ (for-each (lambda (row)
+ (let loop ((cells (%table-row-cells row))
+ (col 0))
+ (if (pair? cells)
+ (let* ((cell (car cells))
+ (cspan (%table-cell-colspan cell))
+ (swidth (%table-cell-width cell)))
+ (if (number? swidth)
+ (let* ((swidth (if (fixnum? swidth)
+ swidth
+ (inexact->exact
+ (* swidth twidth))))
+ (cswidth (/ swidth cspan)))
+ (do ((j 0 (+fx j 1)))
+ ((=fx j cspan)
+ (loop (cdr cells)
+ (+fx col cspan)))
+ (if (< (vector-ref rsizes (+ col j))
+ cswidth)
+ (vector-set! rsizes
+ (+ col j)
+ cswidth))))
+ (loop (cdr cells) (+fx col cspan)))))))
+ (%table-rows table))
+ rsizes))
+
+;*---------------------------------------------------------------------*/
+;* smallest-map ... */
+;*---------------------------------------------------------------------*/
+(define (smallest-map f l1 l2)
+ (if (or (null? l1) (null? l2))
+ '()
+ (cons (f (car l1) (car l2)) (smallest-map f (cdr l1) (cdr l2)))))