From 81750b833c3ecc8b159abf71ec3ec3b6cf7b9a53 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Nov 2008 23:30:13 +0100 Subject: Turn `(skribilo utils text-table)' into a Guile module. --- src/guile/skribilo/utils/text-table.scm | 144 +++++++++++++++++++------------- 1 file changed, 84 insertions(+), 60 deletions(-) (limited to 'src') diff --git a/src/guile/skribilo/utils/text-table.scm b/src/guile/skribilo/utils/text-table.scm index 20dbb23..2f6d2d2 100644 --- a/src/guile/skribilo/utils/text-table.scm +++ b/src/guile/skribilo/utils/text-table.scm @@ -1,42 +1,63 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; text-table.scm -- Producing ASCII tables. +;;; +;;; Copyright 2008 Ludovic Courtès +;;; Copyright 2001 Manuel Serrano +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module __scribetext_table +(define-module (skribilo utils text-table) + :use-module (skribilo ast) + :use-module (skribilo table) + :use-module (skribilo utils justify) + :use-module (skribilo utils syntax) - (library scribeapi) + :export (table->ascii)) - (import __scribetext_justify) - - (export (table->ascii ::%table ::procedure))) +;;; Author: Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Provide a procedure, `table->ascii', that produces a representation of +;;; the given table using ASCII symbols. +;;; +;;; Code: +(fluid-set! current-reader %skribilo-module-reader) + + ;*---------------------------------------------------------------------*/ ;* table->ascii ... */ ;*---------------------------------------------------------------------*/ (define (table->ascii obj scribe->ascii) - (with-access::%table obj (width nbcols rows) - (let* ((nc::long nbcols) - (awidth (-fx (cond - ((fixnum? width) + (let ((width (markup-option obj :width)) + (nbcols (table-column-count obj)) + (rows (markup-body obj))) + (let* ((nc nbcols) + (awidth (- (cond + ((integer? width) width) - ((flonum? width) + ((inexact? 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)) + (- nc 1))) + (colswidth (rows-requested-sizes obj nc awidth)) + (lcolswidth (vector->list colswidth)) (nb-def-cols (length (filter (lambda (s) (= s 0)) lcolswidth))) (defcolwidth (if (= nb-def-cols 0) 0 @@ -47,18 +68,18 @@ ;; of the table, we now compute the exact col sizes (let loop ((i 0) (sum 0)) - (if (=fx i nc) + (if (= i nc) ;; we adjust (because of modulo approx) the last column - (if (not (=fx sum awidth)) + (if (not (= sum awidth)) (vector-set! colswidth - (-fx i 1) - (+fx (vector-ref colswidth (-fx i 1)) - (-fx awidth sum)))) + (- i 1) + (+ (vector-ref colswidth (- i 1)) + (- 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)))))) + (loop (+ i 1) (+ sum defcolwidth))) + (loop (+ i 1) (+ sum (vector-ref colswidth i)))))) ;; at that point colswidth contains the width of each colums. (let ((lcolswidth (vector->list colswidth)) (hrows (map (lambda (r) @@ -87,39 +108,38 @@ ;*---------------------------------------------------------------------*/ ;* table-row-format ... */ ;*---------------------------------------------------------------------*/ -(define (table-row-format row::%table-row nbcols::int colswidth scribe->ascii) +(define (table-row-format row nbcols 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 ((v (do ((i cnum (+ i 1)) + (w 0 (+ w (vector-ref colswidth i)))) + ((= i (+ cnum cspan)) w)))) + (+ v (- cspan 1)))) + (let ((cells (markup-body row))) (let loop ((cells cells) (cnum 0) (res '())) (cond ((pair? cells) (let* ((cell (car cells)) - (cspan (%table-cell-colspan cell)) + (cspan (markup-option cell :colspan)) (cell-width (cell-width cnum cspan))) (loop (cdr cells) - (+fx cnum cspan) + (+ cnum cspan) (cons (table-cell-format cell cell-width scribe->ascii) res)))) - ((=fx cnum nbcols) + ((= 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 "")) + (+ cnum 1) + (cons (cons #f ;; XXX: It's unclear why we need it (list eline)) res)))))))) ;*---------------------------------------------------------------------*/ -;* table-cell-format ::table-cell ... */ +;* 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 */ @@ -132,8 +152,9 @@ ;* 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) +(define (table-cell-format obj width scribe->ascii) + (let ((align (markup-option obj :align)) + (body (markup-body obj))) (cons obj (let ((fmt (with-justification/noflush (make-justifier width @@ -162,17 +183,17 @@ ;* 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 (table-cell-vformat p nblines 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) + (if (= lfmt nblines) fmt (let* ((new (- nblines lfmt)) (new/2 (inexact->exact (/ new 2)))) - (case (%table-cell-valign cell) + (case (markup-option cell :valign) ((top) (append fmt (make-filler-lines new))) ((bottom) @@ -192,29 +213,29 @@ (define (rows-requested-sizes table nbcols twidth) (let ((rsizes (make-vector nbcols 0))) (for-each (lambda (row) - (let loop ((cells (%table-row-cells row)) + (let loop ((cells (markup-body row)) (col 0)) (if (pair? cells) (let* ((cell (car cells)) - (cspan (%table-cell-colspan cell)) - (swidth (%table-cell-width cell))) + (cspan (markup-option cell :colspan)) + (swidth (markup-option cell :width))) (if (number? swidth) - (let* ((swidth (if (fixnum? swidth) + (let* ((swidth (if (integer? swidth) swidth (inexact->exact (* swidth twidth)))) (cswidth (/ swidth cspan))) - (do ((j 0 (+fx j 1))) - ((=fx j cspan) + (do ((j 0 (+ j 1))) + ((= j cspan) (loop (cdr cells) - (+fx col cspan))) + (+ col cspan))) (if (< (vector-ref rsizes (+ col j)) cswidth) (vector-set! rsizes (+ col j) cswidth)))) - (loop (cdr cells) (+fx col cspan))))))) - (%table-rows table)) + (loop (cdr cells) (+ col cspan))))))) + (markup-body table)) rsizes)) ;*---------------------------------------------------------------------*/ @@ -224,3 +245,6 @@ (if (or (null? l1) (null? l2)) '() (cons (f (car l1) (car l2)) (smallest-map f (cdr l1) (cdr l2))))) + + +;;; text-table.scm ends here -- cgit v1.2.3