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

Import new table renderer.

Browse source
This commit is contained in:
Dominik Pantůček 2023-06-15 14:26:50 +02:00
parent 3a59a9293a
commit 3f7f1356a4
12 changed files with 3859 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

527
src/sgr-block.scm Normal file
View file

@ -0,0 +1,527 @@
;;
;; sgr-block.scm
;;
;; Represents a block of sgr-list rows.
;;
;; 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 sgr-block))
(module
sgr-block
(
sgr-list->sgr-block
sgr-block->string-list
sgr-block-width
sgr-block-height
sgr-line-render
sgr-block-render
sgr-block-vexpand
sgr-block-happend
sgr-block-tests!
)
(import scheme
(chicken base)
racket-kwargs
sgr-state
sgr-list
testing)
;; Converts sgr-list (possibly containing multiple lines) into a
;; sgr-block
(define* (sgr-list->sgr-block sl
(initial-state empty-sgr-state))
(let loop ((sl sl)
(state initial-state)
(row '())
(res '()))
(if (null? sl)
(reverse (if (null? row)
res
(cons (reverse row) res)))
(let ((token (car sl)))
(cond
((sgr-token-newline? token)
(loop (cdr sl)
state
(list state)
(cons (reverse row) res)))
((sgr-state? token)
(loop (cdr sl)
token
(if (or (null? row)
(not (sgr-state? (car row))))
(cons token row)
(cons token (cdr row)))
res))
(else
(loop (cdr sl)
state
(cons token row)
res)))))))
;; Creates a plain list of strings from given block
(define* (sgr-block->string-list sb #:reset-state (reset-state #f))
(map (lambda (sl)
(sgr-list->string sl
#:reset-state reset-state))
sb))
;; Returns the width of the longest SGR line in the block
(define (sgr-block-width sb)
(apply max (map sgr-list-length/stretch sb)))
;; Returns the number of SGR lines in the block
(define (sgr-block-height sb)
(length sb))
;; Creates filler for justification of SGR lines
(define (make-sgr-list-filler n)
(cons (make-string n #\space) n))
;; If first or last non-sgr-state token is space, removes it,
;; converts all spaces to glues. Removes unglue.
(define (sgr-line-preprocess sl justify?)
(let loop ((sl sl)
(res '())
(content? #f))
(if (null? sl)
(if (and (not (null? res))
(sgr-token-spaces? (car res)))
(reverse (cdr res))
(if (and (not (null? (cdr res)))
(sgr-state? (car res))
(sgr-token-spaces? (cadr res)))
(reverse (cons (car res)
(cddr res)))
(reverse res)))
(let ((t (car sl)))
(loop (cdr sl)
(if (sgr-token-spaces? t)
(if content?
(cons (if justify?
(cons "\t" 1)
t)
res)
res)
(if (sgr-token-unglue? t)
res
(cons t res)))
(or content?
(and (not (sgr-token-spaces? t))
(not (sgr-token-unglue? t)))))))))
;; Splits the remaining evenly prefering first and last
(define (compute-glue-lens num-glues remaining)
(let loop ((num num-glues)
(remaining remaining)
(res '()))
(if (eq? num 0)
(if (<= num 2)
(reverse res)
(let* ((res0 (reverse res))
(first-glue (car res0))
(rem-glues (cdr res0)))
(cons first-glue
(reverse rem-glues))))
(let ((len (quotient remaining num)))
(loop (sub1 num)
(- remaining len)
(cons len res))))))
;; Expands given SGR line to width by expanding spaces
(define (sgr-line-expand sl width)
(let* ((sll (sgr-list-length-w/o-glues sl))
(rem0 (- width sll)))
(if (>= rem0 0)
(let ((num-glues (sgr-list-num-glues sl)))
(if (> num-glues 0)
(let loop ((gluelens (compute-glue-lens
num-glues
rem0))
(sl sl)
(res '()))
(if (null? sl)
(reverse res)
(let ((tk (car sl)))
(if (sgr-token-glue? tk)
(loop (cdr gluelens)
(cdr sl)
(cons (cons (make-string (car gluelens))
(car gluelens))
res))
(loop gluelens
(cdr sl)
(cons (car sl) res))))))
;; Nothing to expand, fill-in remainder with spaces
(reverse (cons (cons (make-string rem0) rem0)
(reverse sl)))))
;; Nowhere to expand
sl)))
;; Returns justification type: left, right, center, justify
(define (analyze-sgr-line sl)
(if (null? sl)
'left
(let* ((tk0 (if (sgr-state? (car sl))
(if (null? (cdr sl))
#f
(cadr sl))
(car sl)))
(rsl (reverse sl))
(tkl (if (sgr-state? (car rsl))
(if (null? (cdr rsl))
#f
(cadr rsl))
(car rsl))))
(if (not tk0)
'left
(if (sgr-token-glue? tk0)
(if (sgr-token-glue? tkl)
'center
'right)
(if (sgr-token-unglue? tkl)
'justify
'left))))))
;; Extracts initial state
(define (sgr-line-extract-initial-state sl initial-state)
(if (null? sl)
(values sl initial-state)
(if (sgr-state? (car sl))
(values (cdr sl) (car sl))
(if (and (not (null? (cdr sl)))
(sgr-state? (cadr sl)))
(values (cons (car sl)
(cddr sl))
(cadr sl))
(values sl initial-state)))))
;; Finishes line handling right glue properly
(define (sgr-line-finish sl rightglue?)
(if (null? sl)
(if rightglue?
(list (cons "\t" 1))
'())
(if rightglue?
(if (sgr-token-spaces? (car sl))
(reverse (cons (cons "\t" 1)
(cdr sl)))
(reverse (cons (cons "\t" 1)
sl)))
(if (sgr-token-spaces? (car sl))
(reverse (cdr sl))
(reverse sl)))))
;; Returns a list of wrapped sgr-lines and final state
(define (sgr-line-wrap sl-arg width height initial-state-arg leftglue? rightglue? justify?)
(let-values (((sl initial-state) (sgr-line-extract-initial-state sl-arg initial-state-arg)))
(let loop ((sl sl)
(line (if leftglue?
(list (cons "\t" 1) initial-state)
(list initial-state)))
(content? #f)
(llen 0)
(res '())
(rheight 1)
(state initial-state))
(if (or (null? sl)
(and height
(> rheight height)))
(values (if content?
(reverse (cons (sgr-line-finish line rightglue?)
res))
(reverse res))
state)
(let ((tk (car sl)))
(if (sgr-state? tk)
;; State change, add and keep
(loop (cdr sl)
(cons tk line)
content?
llen
res
rheight
tk)
(let ((tklen (cdr tk)))
;; Spaces, texts
(if (sgr-token-spaces? tk)
;; Append only after content
(if (> (+ llen tklen) width)
;; Spaces force line wrap
(loop (cdr sl)
(if leftglue?
(list (cons "\t" 1) state)
(list state))
#f
0
(cons (sgr-line-finish line rightglue?)
res)
(add1 rheight)
state)
;; Spaces continue on the same line
(loop (cdr sl)
(if content?
(cons tk line)
line)
content?
(if content?
(+ llen tklen)
llen)
res
rheight
state))
(if (> (+ llen tklen) width)
;; Wrap word
(loop (cdr sl)
(if leftglue?
(list tk (cons "\t" 1) state)
(list tk state))
#t
tklen
(cons (sgr-line-finish line rightglue?)
res)
(add1 rheight)
state)
;; Keep on going
(loop (cdr sl)
(cons tk line)
#t
(+ llen tklen)
res
rheight
state))))))))))
;; Neutralizes line like sgr-list-neutralize, but returns final state
;; as well
(define (sgr-line-neutralize sl initial-state)
(let loop ((sl sl)
(res '())
(state initial-state))
(if (null? sl)
(values (reverse res)
state)
(let ((tk (car sl)))
(loop (cdr sl)
(cons (sgr-token-neutralize tk) res)
(if (sgr-state? tk)
tk
state))))))
;; Renders single SGR line as block. If width is unspecified, only
;; glues are removed. If height is unspecified, the block can have
;; any height. With width the line is rendered and glues are expanded
;; accordingly. With #:justify all spaces are glues and first and
;; last are removed before rendering. If there are no glues, the
;; width is set and the result is shorter than the specified width,
;; the line is simply right-padded with #\space.
(define* (sgr-line-render sl
#:width (width #f)
#:height (height #f)
#:initial-state (initial-state empty-sgr-state))
(if width
(let* ((alignment (analyze-sgr-line sl))
(sl (sgr-line-preprocess sl (eq? alignment 'justify))))
(let-values (((slw state)
(sgr-line-wrap sl
width height
initial-state
(memq alignment '(right center))
(memq alignment '(left center))
(eq? alignment 'justify))))
(values (map (lambda (sl)
(let ((sle (sgr-line-expand sl width)))
sle))
(if (null? slw)
(list '())
slw))
state)))
(let-values (((sln) (sgr-list-neutralize sl)))
(values sln initial-state))))
;; Renders all the lines and appends the resulting blocks
(define* (sgr-block-render sb
#:width (width (sgr-block-width sb))
#:height (height #f)
#:initial-state (initial-state empty-sgr-state))
(let loop ((sb sb)
(res '())
(total-height 0)
(state initial-state))
(if (or (null? sb)
(and height
(> total-height height)))
(let ((res (if (and height
(< total-height height))
(let floop ((res0 '())
(idx (if height
(- height total-height)
0)))
(if (= idx 0)
(cons res0 res)
(floop (cons (sgr-line-expand (list state (cons "\t" 1))
width)
res0)
(sub1 idx))))
res)))
(apply append (reverse res)))
(let ((sl (car sb)))
(let-values (((slb final-state)
(sgr-line-render sl
#:width width
#:height (if height
(- height total-height)
height)
#:initial-state state)))
(loop (cdr sb)
(cons slb
res)
(+ total-height
(sgr-block-height slb))
final-state
))))))
;; Expands to given height
(define (sgr-block-vexpand sb h)
(let ((sbh (sgr-block-height sb)))
(if (>= sbh h)
sb
(let* ((rsb (reverse sb))
(sbw (if (null? sb)
0
(sgr-list-length (car sb))))
(state (if (null? sb)
0
(sgr-list-last-state (car rsb))))
(filler (list state
(cons (make-string sbw)
sbw))))
(let loop ((rsb rsb)
(rh (- h sbh)))
(if (= 0 rh)
(reverse rsb)
(loop (cons filler rsb)
(sub1 rh))))))))
;; Appends blocks horizontally
(define (sgr-block-happend b0 . rest)
(if (null? rest)
b0
(let loop ((b0 b0)
(b1 (car rest))
(rres '()))
(if (null? b0)
(apply sgr-block-happend
(reverse rres)
(cdr rest))
(loop (cdr b0)
(cdr b1)
(cons (append (car b0)
(car b1))
rres))))))
;; Module self-tests
(define (sgr-block-tests!)
(run-tests
sgr-block
(test-equal? sgr-list->sgr-block
(sgr-list->sgr-block '(("Hello" . 5)))
'((("Hello" . 5))))
(test-equal? sgr-list->sgr-block
(sgr-list->sgr-block '(("Hello" . 5)
("\n" . 1)
("World" . 5)))
'((("Hello" . 5))
(0 ("World" . 5))))
(test-equal? sgr-list->sgr-block
(sgr-list->sgr-block '(1
("Hello" . 5)
("\n" . 1)
0
("World" . 5)))
'((1 ("Hello" . 5))
(0 ("World" . 5))))
(test-equal? sgr-block->string-list
(sgr-block->string-list '((("Hello" . 5))
(1 ("World" . 5))))
'("Hello"
"\x1b[1mWorld"))
(test-equal? sgr-block-width
(sgr-block-width '((("Hello" . 5))
(("Scheme" . 6)
(" " . 1)
("World!" . 6))))
13)
(test-equal? sgr-line-preprocess
(sgr-line-preprocess '(("Hello" . 5)
1
(" " . 3)
0
("World" . 5))
#t)
'(("Hello" . 5)
1
("\t" . 1)
0
("World" . 5)))
(test-equal? sgr-line-preprocess
(sgr-line-preprocess '((" " . 2)
("Hello" . 5)
1
(" " . 3)
0
("World" . 5)
(" " . 2))
#t)
'(("Hello" . 5)
1
("\t" . 1)
0
("World" . 5)))
(test-equal? compute-glue-lens
(compute-glue-lens 1 10)
'(10))
(test-equal? compute-glue-lens
(compute-glue-lens 2 10)
'(5 5))
(test-equal? compute-glue-lens
(compute-glue-lens 2 11)
'(5 6))
(test-equal? compute-glue-lens
(compute-glue-lens 3 11)
'(3 4 4))
(test-equal? compute-glue-lens
(compute-glue-lens 3 14)
'(4 5 5))
(test-equal? sgr-line-expand
(sgr-line-expand
'(("Hello" . 5) ("\t" . 1) ("World!" . 6))
20)
'(("Hello" . 5) (" " . 9) ("World!" . 6)))
))
)