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(-)
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 <ludo@gnu.org>
+;;; 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