← Back to branch summary

~ubuntu-branches/ubuntu/hardy/texmacs/hardy

« back to all changes in this revision

Viewing changes to TeXmacs/progs/convert/tools/tmtable.scm

  • Committer: Bazaar Package Importer
  • Author(s): Ralf Treinen
  • Date: 2004-04-19 20:34:00 UTC
  • Revision ID: james.westby@ubuntu.com-20040419203400-g4e34ih0315wcn8v
Tags: upstream-1.0.3-R2
Import upstream version 1.0.3-R2

Show diffs side-by-side

added added

removed removed

Lines of Context:
TeXmacs/progs/convert/tools/tmtable.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : tmtable.scm
 
5
;; DESCRIPTION : tools for converting tables from and to other formats
 
6
;; COPYRIGHT   : (C) 2002  David Allouche, Joris van der Hoeven
 
7
;;
 
8
;; This software falls under the GNU general public license and comes WITHOUT
 
9
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
 
10
;; If you don't have this file, write to the Free Software Foundation, Inc.,
 
11
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
12
;;
 
13
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
14
 
 
15
(texmacs-module (convert tools tmtable)
 
16
  (:use (convert tools tmlength) (convert tools tmcolor))
 
17
  (:export
 
18
   ;; Constructor
 
19
   tmtable? tmtable
 
20
   tmtable-nrows tmtable-ncols tmtable-cell
 
21
   ;; Table formats
 
22
   tmformat-frame tmformat-table
 
23
   tmformat-table-but-top tmformat-table-but-bottom
 
24
   tmformat-table-but-left tmformat-table-but-right
 
25
   tmformat-cell
 
26
   ;; Output
 
27
   tmtable->stm
 
28
   ;; Parser
 
29
   tmtable-parser
 
30
   tmtable-block-borders tmtable-cell-halign))
 
31
 
 
32
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
33
;; Utilities
 
34
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
35
 
 
36
(define (list-max l)
 
37
  ;; WARNING: not portable for long lists
 
38
  (apply max l))
 
39
 
 
40
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
41
;; Generic table abstraction
 
42
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
43
 
 
44
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
45
;; Foundation
 
46
 
 
47
(define tmtable-type (make-record-type "tmtable" '(nrows ncols cells formats)))
 
48
(define tmtable-record (record-constructor tmtable-type))
 
49
(define tmtable? (record-predicate tmtable-type))
 
50
(define tmtable-nrows (record-accessor tmtable-type 'nrows))
 
51
(define tmtable-ncols (record-accessor tmtable-type 'ncols))
 
52
(define tmtable-cells (record-accessor tmtable-type 'cells))
 
53
(define tmtable-formats (record-accessor tmtable-type 'formats))
 
54
 
 
55
(define (tmtable formats cells)
 
56
  ;; Public tmtable constructor
 
57
  (tmtable-record (length cells)
 
58
                  (list-max (map length cells))
 
59
                  cells
 
60
                  formats))
 
61
 
 
62
(define (tmtable-cell t i j)
 
63
  ;; Content of a given cell
 
64
  (list-ref (list-ref (tmtable-cells t) i) j))
 
65
 
 
66
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
67
;; Table format
 
68
 
 
69
(define (tmformat-frame name value)
 
70
  `(twith ,name ,value))
 
71
 
 
72
;; NOTE: if this list gets too long, we might define region arithmetic.
 
73
;; This might also be needed for format simplification.
 
74
(define (tmformat-table name value)
 
75
  `(cwith 1 -1 1 -1 ,name ,value))
 
76
(define (tmformat-table-but-top name value)
 
77
  `(cwith 2 -1 1 -1 ,name ,value))
 
78
(define (tmformat-table-but-bottom name value)
 
79
  `(cwith 1 -2 1 -1 ,name ,value))
 
80
(define (tmformat-table-but-left name value)
 
81
  `(cwith 1 -1 2 -1 ,name ,value))
 
82
(define (tmformat-table-but-right name value)
 
83
  `(cwith 1 -1 1 -2 ,name ,value))
 
84
(define (tmformat-cell i j name value)
 
85
  `(cwith ,i ,i ,j ,j ,name ,value))
 
86
 
 
87
(define (tmformat-frame? f) (func? f 'twith))
 
88
(define (tmformat-cell? f) (func? f 'cwith))
 
89
(define (tmformat-cell-name f) (sixth f))
 
90
(define (tmformat-cell-value f) (seventh f))
 
91
 
 
92
(define (tmtable-format-on-cell? t f i j)
 
93
  (and (tmformat-cell? f)
 
94
       (with (sym I1 I2 J1 J2 var val) f
 
95
         (let ((i1 (decode-row t I1))
 
96
               (i2 (decode-row t I2))
 
97
               (j1 (decode-column t J1))
 
98
               (j2 (decode-column t J2)))
 
99
           (and (>= i i1) (<= i i2)
 
100
                (>= j j2) (<= j j2))))))
 
101
 
 
102
(define (tmtable-format-on-row? t f i)
 
103
  (and (tmformat-cell? f)
 
104
       (with (sym I1 I2 J1 J2 var val) f
 
105
         (and (== 1 J1) (== -1 J2)
 
106
              (let ((i1 (decode-row t I1))
 
107
                    (i2 (decode-row t I2)))
 
108
                (and (>= i i1) (<= i i2)))))))
 
109
 
 
110
(define (tmtable-format-on-column? t f j)
 
111
  (and (tmformat-cell? f)
 
112
       (with (sym I1 I2 J1 J2 var val) f
 
113
         (and (== 1 I1) (== -1 I2)
 
114
              (let ((j1 (decode-column t J1))
 
115
                    (j2 (decode-column t J2)))
 
116
                (and (>= j j1) (<= j j2)))))))
 
117
 
 
118
(define (decode i n) (cond ((< i 0) (+ i n)) ((> i 0) (1- i)) (else 0)))
 
119
(define (decode-row t i) (decode i (tmtable-nrows t)))
 
120
(define (decode-column t j) (decode j (tmtable-ncols t)))
 
121
 
 
122
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
123
;; Table format partitioning
 
124
 
 
125
(define (tmtable-format-partition-by-column t fs)
 
126
  (map (lambda (j)
 
127
         (list-filter
 
128
          fs (cut tmtable-format-on-column? t <> j)))
 
129
       (iota (tmtable-ncols t))))
 
130
 
 
131
(define (tmtable-format-partition-by-row t fs)
 
132
  (map (lambda (j)
 
133
         (list-filter
 
134
          fs (cut tmtable-format-on-row? t <> j)))
 
135
       (iota (tmtable-nrows t))))
 
136
 
 
137
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
138
;; TODO: simplification of formats.
 
139
;;   remove ignored formats
 
140
;;   collect formats which apply to whole lines/rows/table
 
141
;;   collect formats which apply to ranges of cells/lines/rows
 
142
;;     (giving precedence to extensible boundaries in case of conflict)
 
143
 
 
144
(define (tmtable-simplify t) (noop t))
 
145
 
 
146
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
147
;; TeXmacs table parsing
 
148
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
149
 
 
150
;; A TeXmacs table is a TABLE primitive or a TFORMAT containing a number of
 
151
;; properties item and terminated by a TABLE or a TFORMAT.
 
152
;;
 
153
;; The TFORMAT properties apply to arbitrary contiguous ranges of the table.
 
154
;;
 
155
;; The properties defined in inner TFORMAT take precedence, so the TFORMAT must
 
156
;; be read in preorder. In a simple implementation, the TABLE would then be
 
157
;; read last.
 
158
 
 
159
(define (stm-table-cell-content x)
 
160
  ;; assert (func? x 'cell)
 
161
  (second x))
 
162
 
 
163
(define (stm-table-row->list x)
 
164
  ;; assert (func? x 'row)
 
165
  (map stm-table-cell-content (cdr x)))
 
166
 
 
167
(define (stm-table-cells x)
 
168
  ;; @x must be a TFORMAT or TABLE element
 
169
  ;; Return a list of list of cell contents.
 
170
  ;; Each inner list correspond to a table row.
 
171
  (map stm-table-row->list
 
172
       (do ((x x (last x)))
 
173
           ((func? x 'table) (cdr x)))))
 
174
 
 
175
(define (stm-table-formats x)
 
176
    (cond ((func? x 'table) '())
 
177
          ((func? x 'tformat)
 
178
           (append (map (lambda (f)
 
179
                          (with (sym i1 i2 j1 j2 name value) f
 
180
                            (list sym
 
181
                                  (string->number i1)
 
182
                                  (string->number i2)
 
183
                                  (string->number j1)
 
184
                                  (string->number j2)
 
185
                                  name
 
186
                                  (stm-table-decode-format name value))))
 
187
                        (list-filter (cDdr x) (lambda (l) (= (length l) 7))))
 
188
                   (stm-table-formats (cAr x))))
 
189
         (else '())))
 
190
 
 
191
(define (stm-table-length-name? name)
 
192
  (in? name
 
193
       '("cell-width" "cell-height"
 
194
         "cell-lsep" "cell-rsep" "cell-bsep" "cell-tsep"
 
195
         "cell-lborder" "cell-rborder" "cell-bborder" "cell-tborder"
 
196
         "table-width" "table-height"
 
197
         "table-lsep" "table-rsep" "table-bsep" "table-tsep"
 
198
         "table-lborder" "table-rborder" "table-bborder" "table-tborder")))
 
199
 
 
200
(define (stm-table-number-name? name)
 
201
  (in? name
 
202
       '("cell-row-span" "cell-col-span"
 
203
         "table-row-origin" "table-col-origin"
 
204
         "table-min-rows" "table-min-cols"
 
205
         "table-max-rows" "table-max-cols")))
 
206
 
 
207
(define (stm-table-color-name? name)
 
208
  (string=? name "cell-background"))
 
209
 
 
210
(define (stm-table-decode-format name value)
 
211
  ((cond ((stm-table-length-name? name)
 
212
          string->tmlength)
 
213
         ((stm-table-number-name? name)
 
214
          string->number)
 
215
         ((stm-table-color-name? name)
 
216
          stm->tmcolor)
 
217
         (else noop))
 
218
   (force-string value)))
 
219
 
 
220
(define (stm->tmtable x)
 
221
  (tmtable (reverse (stm-table-formats x))
 
222
           (stm-table-cells x)))
 
223
 
 
224
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
225
;; TeXmacs table output
 
226
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
227
 
 
228
(define (stm-table-encode-format name value)
 
229
  ((cond ((stm-table-length-name? name)
 
230
          tmlength->string)
 
231
         ((stm-table-number-name? name)
 
232
          number->string)
 
233
         ((stm-table-color-name? name)
 
234
          tmcolor->stm)
 
235
         (else noop))
 
236
   value))
 
237
 
 
238
(define (tmtable->stm t)
 
239
  (receive (centered formats)
 
240
      (list-partition (tmtable-formats t)
 
241
                      (cute == <> (tmformat-table "cell-halign" "c")))
 
242
    `(,(if (null? centered) 'tabular 'tabular*)
 
243
      (tformat
 
244
       ,@(reverse!
 
245
          (map (lambda (f)
 
246
                 (cond ((tmformat-cell? f)
 
247
                        (with (sym i1 i2 j1 j2 name value) f
 
248
                          (list sym
 
249
                                (number->string i1) (number->string i2)
 
250
                                (number->string j1) (number->string j2)
 
251
                                name
 
252
                                (stm-table-encode-format name value))))
 
253
                       ((tmformat-frame? f)
 
254
                        (with (sym name value) f
 
255
                          (list sym name
 
256
                                (stm-table-encode-format name value))))))
 
257
               formats))
 
258
       ,(tmtable-cells->stm t)))))
 
259
 
 
260
(define (tmtable-cells->stm t)
 
261
  (cons 'table
 
262
        (map (lambda (r) (cons 'row (map (cut list 'cell <>) r)))
 
263
             (tmtable-cells t))))
 
264
 
 
265
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
266
;; Legacy table parser
 
267
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
268
 
 
269
(define (tmtable-parser x)
 
270
  ;; Internal state
 
271
  (let ((this (stm->tmtable x)))
 
272
 
 
273
    ;; Public getters
 
274
    (define (global name)
 
275
      (cond ((eq? name 'border) (any-border?))
 
276
            ((eq? name 'nrcols) (tmtable-ncols this))))
 
277
    (define (cols name)
 
278
      (cond ((eq? name 'halign) (format-by :column "cell-halign" "l"))
 
279
            ((eq? name 'tborder) (length-non-zero-by :column "cell-tborder"))
 
280
            ((eq? name 'bborder) (length-non-zero-by :column "cell-bborder"))
 
281
            ((eq? name 'lborder) (length-non-zero-by :column "cell-lborder"))
 
282
            ((eq? name 'rborder) (length-non-zero-by :column "cell-rborder"))))
 
283
    (define (rows name)
 
284
      (cond ((eq? name 'content) (tmtable-cells this))
 
285
            ((eq? name 'tborder) (length-non-zero-by :row "cell-tborder"))
 
286
            ((eq? name 'bborder) (length-non-zero-by :row "cell-bborder"))
 
287
            ((eq? name 'lborder) (length-non-zero-by :row "cell-lborder"))
 
288
            ((eq? name 'rborder) (length-non-zero-by :row "cell-rborder"))))
 
289
 
 
290
    ;; Public dispatcher
 
291
    (define (table-parser/dispatch scope . args)
 
292
      (apply (cond ((eq? scope 'global) global)
 
293
                   ((eq? scope 'cols) cols)
 
294
                   ((eq? scope 'rows) rows)) args))
 
295
 
 
296
    ;; Private
 
297
    (define (any-border?)
 
298
      (list-any noop
 
299
                (append (append-map cols '(tborder bborder lborder rborder))
 
300
                        (append-map rows '(tborder bborder lborder rborder)))))
 
301
 
 
302
    (define (format-by axis name default)
 
303
      (map (lambda (fs) (if (null? fs)
 
304
                            default
 
305
                            (tmformat-cell-value (first fs))))
 
306
           ((cond ((eq? axis :row) tmtable-format-partition-by-row)
 
307
                  ((eq? axis :column) tmtable-format-partition-by-column))
 
308
            this
 
309
            (list-filter (tmtable-formats this)
 
310
                         (lambda (f)
 
311
                           (and (tmformat-cell? f)
 
312
                                (== name (tmformat-cell-name f))))))))
 
313
 
 
314
    (define (length-non-zero-by axis name)
 
315
      (map (lambda (len) (not (== 0 (tmlength-value len))))
 
316
           (format-by axis name (tmlength))))
 
317
 
 
318
    ;; evaluate to dispatcher closure
 
319
    table-parser/dispatch))
 
320
 
 
321
(define (tmtable-block-borders x)
 
322
  (if x '((cwith "1" "-1" "1" "1" "cell-lborder" "1ln")
 
323
          (cwith "1" "1" "1" "-1" "cell-tborder" "1ln")
 
324
          (cwith "1" "-1" "1" "-1" "cell-bborder" "1ln")
 
325
          (cwith "1" "-1" "1" "-1" "cell-rborder" "1ln"))
 
326
      '()))
 
327
 
 
328
(define (tmtable-cell-halign x)
 
329
  `((cwith "1" "-1" "1" "-1" "cell-halign" ,x)))