246 lines
7 KiB
Scheme
246 lines
7 KiB
Scheme
;;
|
|
;; 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
|
|
|
|
make-table-vertical-sgr-block
|
|
|
|
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)))))))
|
|
|
|
;; Universal block maker
|
|
(define (make-table-vertical-sgr-block height str)
|
|
(let loop ((height height)
|
|
(res '()))
|
|
(if (= height 0)
|
|
res
|
|
(loop (sub1 height)
|
|
(cons (list 0 (cons str 1))
|
|
res)))))
|
|
|
|
;; 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)))
|
|
(make-table-vertical-sgr-block height str)))
|
|
|
|
;; 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)))))))
|
|
|
|
)
|