Import new table renderer.
This commit is contained in:
parent
3a59a9293a
commit
3f7f1356a4
12 changed files with 3859 additions and 1 deletions
240
src/table-border.scm
Normal file
240
src/table-border.scm
Normal file
|
|
@ -0,0 +1,240 @@
|
|||
;;
|
||||
;; table-border.scm
|
||||
;;
|
||||
;; Table border rendering.
|
||||
;;
|
||||
;; ISC License
|
||||
;;
|
||||
;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
|
||||
;;
|
||||
;; Permission to use, copy, modify, and/or distribute this software
|
||||
;; for any purpose with or without fee is hereby granted, provided
|
||||
;; that the above copyright notice and this permission notice appear
|
||||
;; in all copies.
|
||||
;;
|
||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
||||
;;
|
||||
|
||||
(declare (unit table-border))
|
||||
|
||||
(module
|
||||
table-border
|
||||
(
|
||||
table-rows-border
|
||||
|
||||
table-border-vertical
|
||||
|
||||
table-border-between-rows?
|
||||
|
||||
table-col-separators?
|
||||
|
||||
table-row-merge
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
racket-kwargs
|
||||
box-drawing
|
||||
util-utf8
|
||||
sgr-block)
|
||||
|
||||
;; Vertical separator char (horizontal lines)
|
||||
(define* (table-border-char-vertical top-borders bottom-borders (unicode? #t))
|
||||
(let* ((top-south (line-cell-south top-borders))
|
||||
(bottom-north (line-cell-north bottom-borders))
|
||||
(combined (combine-line-style top-south bottom-north))
|
||||
(cell (make-straight-horizontal-line-cell* combined)))
|
||||
(if unicode?
|
||||
(line-cell->unicode-char cell)
|
||||
(line-cell->ascii-char cell))))
|
||||
|
||||
;; Horizontal separator char (vertical lines)
|
||||
(define* (table-border-char-horizontal left-borders right-borders (unicode? #t))
|
||||
(let* ((left-east (line-cell-east left-borders))
|
||||
(right-west (line-cell-west right-borders))
|
||||
(combined (combine-line-style left-east right-west))
|
||||
(cell (make-straight-vertical-line-cell* combined)))
|
||||
(if unicode?
|
||||
(line-cell->unicode-char cell)
|
||||
(line-cell->ascii-char cell))))
|
||||
|
||||
;; Corner between four adjacent cells
|
||||
(define* (table-border-char-cross tl-b tr-b bl-b br-b (unicode? #t))
|
||||
(let* ((tl-east (line-cell-east tl-b))
|
||||
(tl-south (line-cell-south tl-b))
|
||||
(tr-west (line-cell-west tr-b))
|
||||
(tr-south (line-cell-south tr-b))
|
||||
(bl-north (line-cell-north bl-b))
|
||||
(bl-east (line-cell-east bl-b))
|
||||
(br-north (line-cell-north br-b))
|
||||
(br-west (line-cell-west br-b))
|
||||
(north (combine-line-style tl-east tr-west))
|
||||
(west (combine-line-style tl-south bl-north))
|
||||
(east (combine-line-style tr-south br-north))
|
||||
(south (combine-line-style bl-east br-west))
|
||||
(cell (make-line-cell north west east south)))
|
||||
(if unicode?
|
||||
(line-cell->unicode-char cell)
|
||||
(line-cell->ascii-char cell))))
|
||||
|
||||
;; Appends to list, lst should be pointing at the last cons cell of
|
||||
;; the list, returns the new last cons cell.
|
||||
(define (append-to-list lst ch n)
|
||||
(cond
|
||||
((= 0 n)
|
||||
lst)
|
||||
(else
|
||||
(set-cdr! lst (cons ch '()))
|
||||
(append-to-list (cdr lst) ch (sub1 n)))))
|
||||
|
||||
;; Returns SGR-list of table-rows border
|
||||
;; TODO: add corner only if applicable (add separators argument)
|
||||
(define* (table-rows-border col-widths top-row-borders bottom-row-borders
|
||||
col-separators (unicode? #t))
|
||||
(let ((ch0 (cons #f '()))
|
||||
(trb0 (append (or top-row-borders
|
||||
(map (lambda x 0) bottom-row-borders))
|
||||
(list 0)))
|
||||
(brb0 (append (or bottom-row-borders
|
||||
(map (lambda x 0) top-row-borders))
|
||||
(list 0))))
|
||||
(let loop ((chl ch0)
|
||||
(trb:l (cons 0 trb0))
|
||||
(brb:l (cons 0 brb0))
|
||||
(trb:r trb0)
|
||||
(brb:r brb0)
|
||||
(cws (append col-widths
|
||||
(list 0)))
|
||||
(col-seps col-separators))
|
||||
(if (null? trb:r)
|
||||
(list (list (cons (list->utf8-string (cdr ch0))
|
||||
(length (cdr ch0)))))
|
||||
(let* ((tl (car trb:l))
|
||||
(tr (car trb:r))
|
||||
(bl (car brb:l))
|
||||
(br (car brb:r))
|
||||
(lc (table-border-char-cross tl tr bl br unicode?))
|
||||
(sc (table-border-char-vertical tr br unicode?))
|
||||
(cw (car cws)))
|
||||
(loop (append-to-list (if (car col-seps)
|
||||
(append-to-list chl lc 1)
|
||||
chl)
|
||||
sc cw)
|
||||
(cdr trb:l)
|
||||
(cdr brb:l)
|
||||
(cdr trb:r)
|
||||
(cdr brb:r)
|
||||
(cdr cws)
|
||||
(cdr col-seps)))))))
|
||||
|
||||
;; Returns a SGR-block of correct height
|
||||
(define* (table-border-vertical height left-borders right-borders (unicode? #t))
|
||||
(let* ((ch (table-border-char-horizontal left-borders right-borders unicode?))
|
||||
(str (utf8-char->string ch)))
|
||||
(let loop ((height height)
|
||||
(res '()))
|
||||
(if (= height 0)
|
||||
res
|
||||
(loop (sub1 height)
|
||||
(cons (list 0 (cons str 1))
|
||||
res))))))
|
||||
|
||||
;; Returns true if the border should be drawn between these two rows
|
||||
(define (table-border-between-rows? row0 row1)
|
||||
(let loop ((row0 (if row0
|
||||
row0
|
||||
(map (lambda x 0) row1)))
|
||||
(row1 (if row1
|
||||
row1
|
||||
(map (lambda x 0) row0)))
|
||||
(res #f))
|
||||
(if (null? row0)
|
||||
res
|
||||
(loop (cdr row0)
|
||||
(cdr row1)
|
||||
(or res
|
||||
(not (eq? (table-border-char-vertical (car row0)
|
||||
(car row1) #f)
|
||||
#\space)))))))
|
||||
|
||||
;; Returns a list of boolean values representing the presence of
|
||||
;; column delimiters
|
||||
(define (table-border-between-row-columns? row)
|
||||
(let loop ((row row)
|
||||
(res '())
|
||||
(prev 0))
|
||||
(if (null? row)
|
||||
(reverse (cons (not (eq? (table-border-char-horizontal prev 0 #f)
|
||||
#\space))
|
||||
res))
|
||||
(loop (cdr row)
|
||||
(cons (not (eq? (table-border-char-horizontal prev
|
||||
(car row) #f)
|
||||
#\space))
|
||||
res)
|
||||
(car row)))))
|
||||
|
||||
;; Returns a list of booleans representing the fact that there is a
|
||||
;; column separator at given position. The list contains one more
|
||||
;; value than the number of columns.
|
||||
(define (table-col-separators? borders)
|
||||
(if (null? borders)
|
||||
'()
|
||||
(let loop ((rows (cdr borders))
|
||||
(res (table-border-between-row-columns? (car borders))))
|
||||
(if (null? rows)
|
||||
res
|
||||
(loop (cdr rows)
|
||||
(let rloop ((res0 res)
|
||||
(row0 (table-border-between-row-columns? (car rows)))
|
||||
(res '()))
|
||||
(if (null? res0)
|
||||
(reverse res)
|
||||
(rloop (cdr res0)
|
||||
(cdr row0)
|
||||
(cons (or (car res0)
|
||||
(car row0))
|
||||
res)))))))))
|
||||
|
||||
;; Merges row SGR blocks and intersperses them with separators when
|
||||
;; appropriate.
|
||||
(define (table-row-merge row col-separators borders unicode?)
|
||||
(if (null? row)
|
||||
'()
|
||||
(let ((height (sgr-block-height (car row))))
|
||||
(let loop ((row row)
|
||||
(res '())
|
||||
(seps col-separators) ;; always left first
|
||||
(borders borders)
|
||||
(prev-border 0)
|
||||
)
|
||||
(if (null? row)
|
||||
(apply sgr-block-happend
|
||||
(reverse (if (car seps)
|
||||
(cons (table-border-vertical height
|
||||
prev-border
|
||||
0
|
||||
unicode?)
|
||||
res)
|
||||
res)))
|
||||
(loop (cdr row)
|
||||
(cons (car row)
|
||||
(if (car seps)
|
||||
(cons (table-border-vertical height
|
||||
prev-border
|
||||
(car borders)
|
||||
unicode?)
|
||||
res)
|
||||
res))
|
||||
(cdr seps)
|
||||
(cdr borders)
|
||||
(car borders)))))))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue