brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Improved row border lookup.

Browse source
This commit is contained in:
Dominik Pantůček 2023-03-22 19:48:16 +01:00
parent a2c78df941
commit e95906e631
1 changed files with 58 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

95
table.scm
View file

@ -219,33 +219,52 @@
;; Returns table row delimiter based on column widths, extracting
;; line style from particular row of border style vector.
(define (table-row-delimiter/styled cws svec srow)
(apply table-row-delimiter cws
(map (lambda (idx)
(vector-ref svec (+ idx (* srow 4))))
'(0 1 2 3))))
(define (table-row-delimiter/styled tb cb cws svec srow)
(define (sref i)
(vector-ref svec (+ i (* srow 4))))
(table-row-delimiter cws
(if tb (sref 0) "")
(sref 1)
(if cb (sref 2) "")
(if tb (sref 3) "")))
;; Converts given table to a string suitable for printing.
(define (table->string tbl . args)
(let* ((table-border (get-keyword #:table-border args (lambda () #f)))
(cell-border (get-keyword #:cell-border args (lambda () #f)))
(border-style (get-keyword #:border-style args (lambda () 'ascii)))
(table (table-prepare tbl))
(stylepair (assq border-style table-borders-lookup))
(stylevec (if stylepair
(cdr stylepair)
(cdar table-borders-lookup)))
(cell-borders (if cell-border
(map (lambda (idx)
(vector-ref stylevec idx))
'(4 6 7))
'("" "" ""))))
(string-intersperse
(flatten
(map (lambda (row)
(apply table-row->lines row cell-borders))
table))
"\n")))
(let ((table (table-prepare tbl)))
(if (or (null? tbl)
(null? (car tbl)))
""
(let* ((table-border (get-keyword #:table-border args (lambda () #f)))
(row-border (get-keyword #:row-border args (lambda () #f)))
(column-border (get-keyword #:col-border args (lambda () #f)))
(border-style (get-keyword #:border-style args (lambda () 'ascii)))
(stylepair (assq border-style table-borders-lookup))
(stylevec
(if stylepair
(cdr stylepair)
(cdar table-borders-lookup)))
(cell-borders
(if column-border
(map (lambda (idx)
(vector-ref stylevec idx))
'(4 6 7))
'("" "" ""))))
(let loop ((rows table)
(res '())
(idx 0))
(if (null? rows)
(string-intersperse
(flatten (reverse res))
"\n")
(let* ((res0
(cons
(apply table-row->lines
(car rows)
cell-borders)
res)))
(loop (cdr rows)
res0
(add1 idx)))))))))
;; Performs module self-tests
(define (table-tests!)
@ -308,7 +327,7 @@
(table->string
'(("a" "bb" "ccc" "")
("" "b" "z" "x"))))
(print (table-row-delimiter/styled '(1 2 3 1) (cdr (assq 'unicode table-borders-lookup)) 3))
(print (table-row-delimiter/styled #t #t '(1 2 3 1) (cdr (assq 'unicode table-borders-lookup)) 3))
(print "************")
(print
@ -316,7 +335,7 @@
'(("a" "bb" "ccc" "")
("" "b" "z" "x"))
#:table-border #f
#:cell-border #f
#:col-border #f
))
(print "************")
@ -325,7 +344,17 @@
'(("a" "bb" "ccc" "")
("" "b" "z" "x"))
#:table-border #f
#:cell-border #t
#:col-border #t
))
(print "************")
(print
(table->string
'(("a" "bb" "ccc" "")
("" "b" "z" "x"))
#:table-border #t
#:col-border #f
#:row-border #t
#:border-style 'unicode
))
@ -335,15 +364,7 @@
'(("a" "bb" "ccc" "")
("" "b" "z" "x"))
#:table-border #t
#:cell-border #f
))
(print "************")
(print
(table->string
'(("a" "bb" "ccc" "")
("" "b" "z" "x"))
#:table-border #t
#:cell-border #t
#:row-border #t
#:col-border #t
#:border-style 'unicode
))