532 lines
13 KiB
Scheme
532 lines
13 KiB
Scheme
;;
|
|
;; 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
|
|
util-utf8)
|
|
|
|
;; 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-utf8-string n #\xA0) 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? res))
|
|
(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-utf8-string (car gluelens) #\xA0)
|
|
(car gluelens))
|
|
res))
|
|
(loop gluelens
|
|
(cdr sl)
|
|
(cons (car sl) res))))))
|
|
;; Nothing to expand, fill-in remainder with spaces
|
|
(reverse (cons (cons (make-utf8-string rem0 #\xA0) 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 ((sln (sgr-list-neutralize sl)))
|
|
;;(write sln)(newline)
|
|
(values (list 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-utf8-string sbw #\xA0)
|
|
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)
|
|
("\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0" . 9)
|
|
("World!" . 6)))
|
|
))
|
|
|
|
)
|