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

72
src/Makefile
View file

@ -51,7 +51,10 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \
util-string.o util-io.o util-parser.o texts.o tests.o \ util-string.o util-io.o util-parser.o texts.o tests.o \
util-proc.o util-mail.o notifications.o util-format.o \ util-proc.o util-mail.o notifications.o util-format.o \
brmember-format.o logging.o specification.o util-git.o \ brmember-format.o logging.o specification.o util-git.o \
cal-day.o util-stdout.o cal-format.o util-dict-bst.o cal-day.o util-stdout.o cal-format.o util-dict-bst.o table.o \
sgr-list.o sgr-block.o table-processor.o table-border.o \
table-style.o sgr-state.o util-utf8.o sgr-cell.o \
template-list-expander.o box-drawing.o
.PHONY: imports .PHONY: imports
imports: $(HACKERBASE-DEPS) imports: $(HACKERBASE-DEPS)
@ -389,3 +392,70 @@ util-dict-bst.import.scm: $(UTIL-DICT-BST-SOURCES)
RACKET-KWARGS-SOURCES=racket-kwargs.scm RACKET-KWARGS-SOURCES=racket-kwargs.scm
racket-kwargs.import.scm: $(RACKET-KWARGS-SOURCES) racket-kwargs.import.scm: $(RACKET-KWARGS-SOURCES)
TABLE-SOURCES=table.scm sgr-list.import.scm sgr-block.import.scm \
racket-kwargs.import.scm table-processor.import.scm \
table-border.import.scm table-style.import.scm
table.o: table.import.scm
table.import.scm: $(TABLE-SOURCES)
SGR-LIST-SOURCES=sgr-list.scm raket-kwargs.import.scm \
sgr-state.import.scm testing.import.scm util-utf8.import.scm
sgr-list.o: sgr-list.import.scm
sgr-list.import.scm: $(SGR-LIST-SOURCES)
SGR-BLOCK-SOURCES=sgr-block.scm racket-kwargs.import.scm \
sgr-state.import.scm sgr-list.import.scm testing.import.scm
sgr-block.o: sgr-block.import.scm
sgr-block.import.scm: $(SGR-BLOCK-SOURCES)
TABLE-PROCESSOR-SOURCES=table-processor.scm sgr-cell.import.scm \
template-list-expander.import.scm
table-processor.o: table-processor.import.scm
table-processor.import.scm: $(TABLE-PROCESSOR-SOURCES)
TABLE-BORDER-SOURCES=table-border.scm racket-kwargs.import.scm \
box-drawing.import.scm util-utf8.import.scm \
sgr-block.import.scm
table-border.o: table-border.import.scm
table-border.import.scm: $(TABLE-BORDER-SOURCES)
TABLE-STYLE-SOURCES=table-style.scm box-drawing.import.scm \
testing.import.scm template-list-expander.import.scm
table-style.o: table-style.import.scm
table-style.import.scm: $(TABLE-STYLE-SOURCES)
SGR-STATE-SOURCES=sgr-state.scm testing.import.scm \
racket-kwargs.import.scm
sgr-state.o: sgr-state.import.scm
sgr-state.import.scm: $(SGR-STATE-SOURCES)
UTIL-UTF8-SOURCES=util-utf8.scm testing.import.scm
util-utf8.o: util-utf8.import.scm
util-utf8.import.scm: $(UTIL-UTF8-SOURCES)
SGR-CELL-SOURCES=sgr-cell.scm racket-kwargs.import.scm \
sgr-state.import.scm sgr-list.import.scm sgr-block.import.scm
sgr-cell.o: sgr-cell.import.scm
sgr-cell.import.scm: $(SGR-CELL-SOURCES)
TEMPLATE-LIST-EXPANDER-SOURCES=template-list-expander.scm \
testing.import.scm
template-list-expander.o: template-list-expander.import.scm
template-list-expander.import.scm: $(TEMPLATE-LIST-EXPANDER-SOURCES)
BOX-DRAWING-SOURCES=box-drawing.scm util-utf8.import.scm \
racket-kwargs.import.scm testing.import.scm
box-drawing.o: box-drawing.import.scm
box-drawing.import.scm: $(BOX-DRAWING-SOURCES)

765
src/box-drawing.scm Normal file
View file

@ -0,0 +1,765 @@
;;
;; box-drawing.scm
;;
;; Unicode box drawing combiners.
;;
;; 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 box-drawing))
(module
box-drawing
(
combine-line-cells
line-cell-somewhat-heavy?
line-cell->unicode-char
line-cell->utf8-string
line-cell->ascii-char
char->line-cell
combine-line-char
line-style-none
combine-line-style
line-cell-north
line-cell-east
line-cell-west
line-cell-south
spec->line-style
line-style-spec?
make-line-cell
make-straight-horizontal-line-cell
make-straight-vertical-line-cell
make-straight-horizontal-line-cell*
make-straight-vertical-line-cell*
line-cell-none
set-line-cell-north
set-line-cell-west
set-line-cell-east
set-line-cell-south
spec->horizontal-line-cell
spec->vertical-line-cell
spec->top-left-corner-line-cell
spec->top-right-corner-line-cell
spec->bottom-left-corner-line-cell
spec->bottom-right-corner-line-cell
extract-line-cell-top-left
extract-line-cell-top-right
extract-line-cell-bottom-left
extract-line-cell-bottom-right
box-drawing-tests!
)
(import scheme
(chicken base)
(chicken bitwise)
util-utf8
racket-kwargs
testing)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Bit manipulators
(define-syntax define-bit-predicate
(syntax-rules ()
((_ name mask value)
(define (name bits)
(= (bitwise-and bits mask) value)))))
(define-syntax define-bit-setter
(syntax-rules ()
((_ name andmask ormask)
(define (name bits)
(bitwise-ior (bitwise-and bits andmask) ormask)))))
(define-syntax define-bit-combiner
(syntax-rules ()
((_ name mask)
(define (name a b)
(bitwise-ior
(bitwise-and a mask)
(bitwise-and b mask))))))
(define-syntax define-bit-accessor
(syntax-rules ()
((_ name shift mask)
(define (name bits)
(bitwise-and
(arithmetic-shift bits (- shift)) mask)))))
(define-syntax define-bit-accessor-setter
(syntax-rules ()
((_ name shift mask)
(define (name bits ormask)
(bitwise-ior (bitwise-and (bitwise-not (arithmetic-shift mask shift))
bits)
(arithmetic-shift (bitwise-and ormask mask)
shift))))))
(define-syntax define-inverted-bit-predicate
(syntax-rules ()
((_ name mask value)
(define (name bits)
(not (= (bitwise-and bits mask) 0))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Line thickness
;; * none
;; * light
;; * heavy
;; Bit indices: 10
;; ||_ lower bit: light thickness
;; |_ higher bit: heavy thickness
;; Values:
;; 00 - none
;; 01 - light
;; 10 - heavy
;; 11 - heavy
(define line-thickness-none 0)
(define line-thickness-light 1)
(define line-thickness-heavy 2)
(define-bit-predicate line-thickness-light? 3 1)
(define-bit-predicate line-thickness-heavy? 2 2)
(define-bit-predicate line-thickness-none? 3 0)
(define-bit-setter set-line-thickness-light 3 1)
(define-bit-setter set-line-thickness-heavy 3 2)
(define-bit-setter set-line-thickness-none 0 0)
(define-bit-combiner combine-line-thickness 3)
(define-inverted-bit-predicate line-thickness-some? 3 0)
(define (line-thickness-normalize thickness)
(if (line-thickness-heavy? thickness)
line-thickness-heavy
thickness))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Line type
;; * none
;; * dashed
;; * solid
;; Bit indices: 10
;; ||_ lower bit: dashed type
;; |_ higher bit: solid type
;; Values:
;; * 00 - none
;; * 01 - dashed
;; * 10 - solid
;; * 11 - solid
(define line-type-none 0)
(define line-type-dashed 1)
(define line-type-solid 2)
(define-bit-predicate line-type-dashed? 3 1)
(define-bit-predicate line-type-solid? 2 2)
(define-bit-predicate line-type-none? 3 0)
(define-bit-setter set-line-type-dashed 3 1)
(define-bit-setter set-line-type-solid 3 2)
(define-bit-setter set-line-type-none 0 0)
(define-bit-combiner combine-line-type 3)
(define-inverted-bit-predicate line-type-some? 3 0)
(define (line-type-normalize type)
(if (line-type-solid? type)
line-type-solid
type))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Line style
;; * thickness
;; * type
;; Double-bit indices: 10
;; ||_ lower nibble: thickness
;; |_ higher nibble: type
;; Bit indices: 3210
;; ||||_ light thickness
;; |||_ heavy thickness
;; ||_ dashed type
;; |_ solid type
(define line-style-none 0)
;; Creates line style from specific thickness and type
(define (make-line-style thickness type)
(bitwise-ior
(arithmetic-shift (bitwise-and type 3) 2)
(bitwise-and (bitwise-and thickness 3))))
(define-bit-accessor line-style-thickness 0 3)
(define-bit-accessor line-style-type 2 3)
(define-bit-predicate line-style-thickness-light? 3 1)
(define-bit-predicate line-style-thickness-heavy? 2 2)
(define-bit-predicate line-style-thickness-none? 3 0)
(define-bit-predicate line-style-type-dashed? 12 4)
(define-bit-predicate line-style-type-solid? 8 8)
(define-bit-predicate line-style-type-none? 12 0)
(define-bit-setter set-line-style-thickness-light 15 1)
(define-bit-setter set-line-style-thickness-heavy 15 2)
(define-bit-setter set-line-style-thickness-none 12 0)
(define-bit-setter set-line-style-type-dashed 15 4)
(define-bit-setter set-line-style-type-solid 15 8)
(define-bit-setter set-line-style-type-none 3 0)
(define-bit-combiner combine-line-style 15)
(define-inverted-bit-predicate line-style-thickness-some? 3 0)
(define-inverted-bit-predicate line-style-type-some? 12 0)
(define (line-style-some? style)
(and (line-style-thickness-some? style)
(line-style-type-some? style)))
(define (line-style-none? style)
(or (line-style-thickness-none? style)
(line-style-type-none? style)))
(define (line-style-normalize style)
(make-line-style
(line-thickness-normalize (line-style-thickness style))
(line-type-normalize (line-style-type style))))
(define (line-style-heavy? style)
(and (line-style-type-some? style)
(line-style-thickness-heavy? style)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Line cell
;; * north
;; * west
;; * east
;; * south
;; Nibble indices: 3210
;; ||||_ north style
;; |||_ west style
;; ||_ east style
;; |_ south style
;; Bit indices: fedcba9876543210
;; ||||||||||||||||_ north light thickness
;; |||||||||||||||_ north heavy thickness
;; ||||||||||||||_ north dashed type
;; |||||||||||||_ north solid type
;; ||||||||||||_ west light thickness
;; |||||||||||_ west heavy thickness
;; ||||||||||_ west dashed type
;; |||||||||_ west solid type
;; ||||||||_ east light thickness
;; |||||||_ east heavy thickness
;; ||||||_ east dashed type
;; |||||_ east solid type
;; ||||_ south light thickness
;; |||_ south heavy thickness
;; ||_ south dashed type
;; |_ south solid type
(define line-cell-none 0)
(define (make-line-cell n w e s)
(bitwise-ior
(bitwise-and n 15)
(arithmetic-shift (bitwise-and w 15) 4)
(arithmetic-shift (bitwise-and e 15) 8)
(arithmetic-shift (bitwise-and s 15) 12)))
(define-bit-accessor line-cell-north 0 15)
(define-bit-accessor line-cell-west 4 15)
(define-bit-accessor line-cell-east 8 15)
(define-bit-accessor line-cell-south 12 15)
(define-bit-accessor-setter set-line-cell-north 0 15)
(define-bit-accessor-setter set-line-cell-west 4 15)
(define-bit-accessor-setter set-line-cell-east 8 15)
(define-bit-accessor-setter set-line-cell-south 12 15)
(define-bit-combiner combine-line-cells 65535)
(define (make-straight-horizontal-line-cell thickness type)
(let ((style (make-line-style thickness type)))
(make-line-cell 0 style style 0)))
(define (make-straight-vertical-line-cell thickness type)
(let ((style (make-line-style thickness type)))
(make-line-cell style 0 0 style)))
(define (make-straight-horizontal-line-cell* style)
(make-line-cell 0 style style 0))
(define (make-straight-vertical-line-cell* style)
(make-line-cell style 0 0 style))
(define (make-cross-line-cell thickness type)
(let ((style (make-line-style thickness type)))
(make-line-cell style style style style)))
(define (line-cell-straight-horizontal? cell)
(and (line-style-none? (line-cell-north cell))
(line-style-none? (line-cell-south cell))
(line-style-some? (line-cell-west cell))
(line-style-some? (line-cell-east cell))
(= (line-style-normalize (line-cell-west cell))
(line-style-normalize (line-cell-east cell)))))
(define (line-cell-straight-vertical? cell)
(and (line-style-some? (line-cell-north cell))
(line-style-none? (line-cell-west cell))
(line-style-none? (line-cell-east cell))
(line-style-some? (line-cell-south cell))
(= (line-style-normalize (line-cell-north cell))
(line-style-normalize (line-cell-south cell)))))
(define (line-cell-mostly-horizontal? cell)
(and (line-style-none? (line-cell-north cell))
(line-style-none? (line-cell-south cell))
(line-style-some? (line-cell-west cell))
(line-style-some? (line-cell-east cell))))
(define (line-cell-mostly-vertical? cell)
(and (line-style-some? (line-cell-north cell))
(line-style-none? (line-cell-west cell))
(line-style-none? (line-cell-east cell))
(line-style-some? (line-cell-south cell))))
(define (line-cell-none? cell)
(and (line-style-none? (line-cell-north cell))
(line-style-none? (line-cell-west cell))
(line-style-none? (line-cell-east cell))
(line-style-none? (line-cell-south cell))))
(define (line-cell-somewhat-heavy? cell)
(or (line-style-heavy? (line-cell-north cell))
(line-style-heavy? (line-cell-west cell))
(line-style-heavy? (line-cell-east cell))
(line-style-heavy? (line-cell-south cell))))
(define (line-cell-straight-horizontal-type cell)
(line-style-type
(line-cell-west cell)))
(define (line-cell-straight-vertical-type cell)
(line-style-type
(line-cell-north cell)))
(define (line-cell-straight-horizontal-dashed? cell)
(and (line-cell-straight-horizontal? cell)
(line-type-dashed?
(line-cell-straight-horizontal-type cell))))
(define (line-cell-straight-vertical-dashed? cell)
(and (line-cell-straight-vertical? cell)
(line-type-dashed?
(line-cell-straight-vertical-type cell))))
(define (line-cell-straight-horizontal-thickness cell)
(line-style-thickness
(line-cell-west cell)))
(define (line-cell-straight-vertical-thickness cell)
(line-style-thickness
(line-cell-north cell)))
(define (line-cell-junction-compress cell)
(let ((n (line-thickness-normalize (line-style-thickness (line-cell-north cell))))
(w (line-thickness-normalize (line-style-thickness (line-cell-west cell))))
(e (line-thickness-normalize (line-style-thickness (line-cell-east cell))))
(s (line-thickness-normalize (line-style-thickness (line-cell-south cell)))))
(+ n
(* w 3)
(* e 9)
(* s 27))))
(define line-cell-char-junctions
(vector ;; SEWN (base-3 representation)
#\space ;; 0000
#\x2575 ;; 0001
#\x2579 ;; 0002
#\x2574 ;; 0010
#\x2518 ;; 0011
#\x251a ;; 0012
#\x2578 ;; 0020
#\x2519 ;; 0021
#\x251b ;; 0022
#\x2576 ;; 0100
#\x2514 ;; 0101
#\x2516 ;; 0102
#\x2500 ;; 0110
#\x2534 ;; 0111
#\x2538 ;; 0112
#\x257e ;; 0120
#\x2535 ;; 0121
#\x2539 ;; 0122
#\x257a ;; 0200
#\x2515 ;; 0201
#\x2517 ;; 0202
#\x257c ;; 0210
#\x2536 ;; 0211
#\x253a ;; 0212
#\x2501 ;; 0220
#\x2537 ;; 0221
#\x253b ;; 0222
#\x2577 ;; 1000
#\x2502 ;; 1001
#\x257f ;; 1002
#\x2510 ;; 1010
#\x2524 ;; 1011
#\x2526 ;; 1012
#\x2511 ;; 1020
#\x2525 ;; 1021
#\x2529 ;; 1022
#\x250c ;; 1100
#\x251c ;; 1101
#\x251e ;; 1102
#\x252c ;; 1110
#\x253c ;; 1111
#\x2540 ;; 1112
#\x252d ;; 1120
#\x253d ;; 1121
#\x2543 ;; 1122
#\x250d ;; 1200
#\x251d ;; 1201
#\x2521 ;; 1202
#\x252e ;; 1210
#\x253e ;; 1211
#\x2544 ;; 1212
#\x252f ;; 1220
#\x253f ;; 1221
#\x2547 ;; 1222
#\x257b ;; 2000
#\x257d ;; 2001
#\x2503 ;; 2002
#\x2512 ;; 2010
#\x2527 ;; 2011
#\x2528 ;; 2012
#\x2513 ;; 2020
#\x252a ;; 2021
#\x252b ;; 2022
#\x250e ;; 2100
#\x251f ;; 2101
#\x2520 ;; 2102
#\x2530 ;; 2110
#\x2541 ;; 2111
#\x2542 ;; 2112
#\x2531 ;; 2120
#\x2545 ;; 2121
#\x2549 ;; 2122
#\x250f ;; 2200
#\x2522 ;; 2201
#\x2523 ;; 2202
#\x2532 ;; 2210
#\x2546 ;; 2211
#\x254a ;; 2212
#\x2533 ;; 2220
#\x2548 ;; 2221
#\x254b ;; 2222
))
(define line-cell-char-horizontal-light-dashed #\x254c)
(define line-cell-char-horizontal-heavy-dashed #\x254d)
(define line-cell-char-vertical-light-dashed #\x254e)
(define line-cell-char-vertical-heavy-dashed #\x254f)
(define (line-cell->unicode-char cell)
(cond ((line-cell-straight-horizontal-dashed? cell)
(let ((thickness (line-cell-straight-horizontal-thickness cell)))
(if (line-thickness-light? thickness)
line-cell-char-horizontal-light-dashed
line-cell-char-horizontal-heavy-dashed)))
((line-cell-straight-vertical-dashed? cell)
(let ((thickness (line-cell-straight-vertical-thickness cell)))
(if (line-thickness-light? thickness)
line-cell-char-vertical-light-dashed
line-cell-char-vertical-heavy-dashed)))
(else
(let ((compressed (line-cell-junction-compress cell)))
(vector-ref line-cell-char-junctions compressed)))))
(define line-cell-string-junctions
(apply
vector
(map utf8-char->string
(vector->list line-cell-char-junctions))))
(define line-cell-string-horizontal-light-dashed
(utf8-char->string line-cell-char-horizontal-light-dashed))
(define line-cell-string-horizontal-heavy-dashed
(utf8-char->string line-cell-char-horizontal-heavy-dashed))
(define line-cell-string-vertical-light-dashed
(utf8-char->string line-cell-char-vertical-light-dashed))
(define line-cell-string-vertical-heavy-dashed
(utf8-char->string line-cell-char-vertical-heavy-dashed))
(define (line-cell->utf8-string cell)
(cond ((line-cell-straight-horizontal-dashed? cell)
(let ((thickness (line-cell-straight-horizontal-thickness cell)))
(if (line-thickness-light? thickness)
line-cell-string-horizontal-light-dashed
line-cell-string-horizontal-heavy-dashed)))
((line-cell-straight-vertical-dashed? cell)
(let ((thickness (line-cell-straight-vertical-thickness cell)))
(if (line-thickness-light? thickness)
line-cell-string-vertical-light-dashed
line-cell-string-vertical-heavy-dashed)))
(else
(let ((compressed (line-cell-junction-compress cell)))
(vector-ref line-cell-string-junctions compressed)))))
(define (line-cell->ascii-char cell)
(cond ((line-cell-mostly-horizontal? cell)
#\-)
((line-cell-mostly-vertical? cell)
#\|)
((line-cell-none? cell)
#\space)
(else
#\+)))
(define line-cell-reverse-lookup (make-vector 128 line-cell-none))
(let loop ((idx 1))
(when (< idx 81)
(let* ((ch (vector-ref line-cell-char-junctions idx))
(cp (char->integer ch))
(ridx (- cp #x2500))
(n (modulo idx 3))
(w (modulo (quotient idx 3) 3))
(e (modulo (quotient idx 9) 3))
(s (modulo (quotient idx 27) 3)))
(vector-set! line-cell-reverse-lookup
ridx
(make-line-cell (make-line-style n line-type-solid)
(make-line-style w line-type-solid)
(make-line-style e line-type-solid)
(make-line-style s line-type-solid)))
(loop (add1 idx)))))
(define* (char->line-cell char #:bold (bold? #f))
(case char
((#\-) (make-straight-horizontal-line-cell bold? 'solid))
((#\|) (make-straight-vertical-line-cell bold? 'solid))
((#\+) (make-cross-line-cell bold? 'solid))
((#\space) line-cell-none)
(else
(let ((cp (char->integer char)))
(cond ((or (< cp #x2500)
(> cp #x257f))
line-cell-none)
(else
(vector-ref line-cell-reverse-lookup (- cp #x2500))))))))
(define (combine-line-char ch1 ch2)
(line-cell->unicode-char
(combine-line-cells
(char->line-cell ch1)
(char->line-cell ch2))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Style specifications
(define (spec->line-thickness spec)
(case spec
((light) line-thickness-light)
((heavy) line-thickness-heavy)
(else line-thickness-none)))
(define (spec->line-type spec)
(case spec
((dashed) line-type-dashed)
((solid) line-type-solid)
(else line-type-none)))
(define (spec->line-style spec)
(cond ((symbol? spec)
(case spec
((light heavy)
(make-line-style (spec->line-thickness spec)
line-type-solid))
((dashed solid)
(make-line-style line-thickness-light
(spec->line-type spec)))
(else 0)))
((list? spec)
(let ((res (foldl
(lambda (acc spec1)
(combine-line-style
acc
(case spec1
((light heavy)
(make-line-style (spec->line-thickness spec1)
line-type-none))
((dashed solid)
(make-line-style line-thickness-none
(spec->line-type spec1)))
(else line-style-none))))
line-style-none
spec)))
(cond ((and (line-style-thickness-some? res)
(line-style-type-none? res))
(set-line-style-type-solid res))
((and (line-style-thickness-none? res)
(line-style-type-some? res))
(set-line-style-thickness-light res))
(else
res))))
(else line-style-none)))
(define (line-style-spec? spec)
(or (memq spec '(none light heavy dashed solid))
(and (list? spec)
(let loop ((lst spec))
(if (null? lst)
#t
(if (line-style-spec? (car spec))
(loop (cdr lst))
#f))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Cell makers
(define-syntax define-spec->line-cell
(syntax-rules ()
((_ name spec style a b c d)
(define (name spec)
(let ((style (spec->line-style spec)))
(make-line-cell a b c d))))))
(define-spec->line-cell spec->horizontal-line-cell spec style 0 style style 0)
(define-spec->line-cell spec->vertical-line-cell spec style style 0 0 style)
(define-spec->line-cell spec->north-west-line-cell spec style style style 0 0)
(define-spec->line-cell spec->north-east-line-cell spec style style 0 style 0)
(define-spec->line-cell spec->south-west-line-cell spec style 0 style 0 style)
(define-spec->line-cell spec->south-east-line-cell spec style 0 0 style style)
(define spec->top-left-corner-line-cell spec->south-east-line-cell)
(define spec->top-right-corner-line-cell spec->south-west-line-cell)
(define spec->bottom-left-corner-line-cell spec->north-east-line-cell)
(define spec->bottom-right-corner-line-cell spec->north-west-line-cell)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Cell extractors
(define ((make-line-cell-extractor n w e s) c)
(let ((sm (if s 15 0))
(em (if e 240 0))
(wm (if w 3840 0))
(nm (if n 61440 0)))
(bitwise-and c (bitwise-ior sm em wm nm))))
(define extract-line-cell-north-west
(make-line-cell-extractor #t #t #f #f))
(define extract-line-cell-north-east
(make-line-cell-extractor #t #f #t #f))
(define extract-line-cell-south-west
(make-line-cell-extractor #f #t #f #t))
(define extract-line-cell-south-east
(make-line-cell-extractor #f #f #t #t))
(define extract-line-cell-top-left extract-line-cell-south-east)
(define extract-line-cell-top-right extract-line-cell-south-west)
(define extract-line-cell-bottom-left extract-line-cell-south-east)
(define extract-line-cell-bottom-right extract-line-cell-south-west)
;; Self-tests
(define (box-drawing-tests!)
(run-tests
box-drawing
(test-equal? spec->line-thickness
(spec->line-thickness 'none)
0)
(test-equal? spec->line-thickness
(spec->line-thickness 'light)
1)
(test-equal? spec->line-thickness
(spec->line-thickness 'heavy)
2)
(test-equal? spec->line-type
(spec->line-type 'none)
0)
(test-equal? spec->line-type
(spec->line-type 'dashed)
1)
(test-equal? spec->line-type
(spec->line-type 'solid)
2)
(test-equal? spec->line-style
(spec->line-style 'solid) ;; light implied
#b1001)
(test-equal? spec->line-style
(spec->line-style 'dashed) ;; light implied
#b101)
(test-equal? spec->line-style
(spec->line-style 'light) ;; solid implied
#b1001)
(test-equal? spec->line-style
(spec->line-style 'heavy) ;; solid implied
#b1010)
(test-equal? combine-line-style
(combine-line-style #b1001 #b110)
#b1111)
(test-equal? spec->line-style
(spec->line-style '(solid light))
#b1001)
(test-equal? spec->line-style
(spec->line-style '(solid)) ;; light implied
#b1001)
(test-equal? spec->line-style
(spec->line-style '(dashed)) ;; light implied
#b101)
(test-equal? spec->line-style
(spec->line-style '(light)) ;; solid implied
#b1001)
(test-equal? spec->line-style
(spec->line-style '(heavy)) ;; solid implied
#b1010)
))
)

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)))
))
)

67
src/sgr-cell.scm Normal file
View file

@ -0,0 +1,67 @@
;;
;; sgr-cell.scm
;;
;; Surface API for handling strings with SGR sequences as table cells.
;;
;; 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-cell))
(module
sgr-cell
(
string->sgr-cell
sgr-cell-width
sgr-cell-height
sgr-cell-min-width
sgr-cell-render
sgr-cell-vexpand
)
(import scheme
racket-kwargs
sgr-state
sgr-list
sgr-block)
(define* (string->sgr-cell str (initial-state empty-sgr-state))
(let ((cell0 (sgr-list->sgr-block
(string->sgr-list/words str initial-state)
initial-state)))
(if (null? cell0)
(list (list initial-state))
cell0)))
(define sgr-cell-width sgr-block-width)
(define sgr-cell-height sgr-block-height)
(define (sgr-cell-min-width sc)
(apply max (cons 0 (map sgr-list-min-width sc))))
(define (sgr-cell-render . args)
(apply sgr-block-render args))
(define sgr-cell-vexpand sgr-block-vexpand)
)

485
src/sgr-list.scm Normal file
View file

@ -0,0 +1,485 @@
;;
;; sgr-list.scm
;;
;; Intermediate representation of strings with SGR state changes.
;;
;; 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-list))
(module
sgr-list
(
string->sgr-list
string->sgr-list/words
sgr-list->string
sgr-list-length
sgr-list-length/stretch
sgr-list-length-w/o-glues
sgr-token-spaces?
sgr-token-glue?
sgr-token-newline?
sgr-token-unglue?
sgr-token-neutralize
sgr-list-neutralize
sgr-list-num-glues
sgr-list-min-width
sgr-list-last-state
sgr-list-tests!
)
(import scheme
(chicken base)
(chicken string)
racket-kwargs
sgr-state
testing
util-utf8)
;; Converts given string into a list of string parts and sgr-states
(define* (string->sgr-list str
(initial-state empty-sgr-state))
(let ((src-len (string-length str)))
(let loop ((src-idx 0)
(token-start 0)
(token-end 0)
(token-pos 0)
(state initial-state)
(res '()))
(if (>= src-idx src-len)
(reverse
(if (= token-start token-end)
res
(cons (cons (substring str token-start token-end)
token-pos)
res)))
(let ((ch (string-ref str src-idx)))
(cond
((eq? ch #\x1b)
(let-values (((sgr-parsed next-idx)
(parse-csi-sgr-sequence+pos str src-idx state)))
(let ((token (update-sgr-state-from-list state sgr-parsed)))
(loop next-idx
next-idx
next-idx
0
token
(cons token
(if (= token-start token-end)
res
(cons (cons (substring str token-start token-end)
token-pos)
res)))))))
(else
(let ((next-idx (utf8-string-next-char str src-idx)))
(loop next-idx
token-start
next-idx
(add1 token-pos)
state
res)))))))))
;; Converts given string into a list of string parts and sgr-states,
;; handling continuous whitespace as separate tokens.
(define* (string->sgr-list/words str
(initial-state empty-sgr-state))
(let ((src-len (string-length str)))
(let loop ((src-idx 0)
(token-start 0)
(token-end 0)
(token-pos 0)
(state initial-state)
(space? #f)
(res '()))
(if (>= src-idx src-len)
(reverse
(if (= token-start token-end)
res
(cons (cons (substring str token-start token-end)
token-pos)
res)))
(let ((ch (string-ref str src-idx)))
(cond
((eq? ch #\x1b)
(let-values (((sgr-parsed next-idx)
(parse-csi-sgr-sequence+pos str src-idx state)))
(let ((token (update-sgr-state-from-list state sgr-parsed)))
(loop next-idx
next-idx
next-idx
0
token
#f
(cons token
(if (= token-start token-end)
res
(cons (cons (substring str token-start token-end)
token-pos)
res)))))))
((eq? ch #\backspace)
(let ((next-idx (add1 src-idx)))
(loop next-idx
next-idx
next-idx
0
state
#f
(cons (cons "\b" 1)
(if (= token-start token-end)
res
(cons (cons (substring str token-start token-end)
token-pos)
res))))))
((eq? ch #\newline)
(let ((next-idx (add1 src-idx)))
(loop next-idx
next-idx
next-idx
0
state
#f
(cons (cons "\n" 1)
(if (= token-start token-end)
res
(cons (cons (substring str token-start token-end)
token-pos)
res))))))
((memq ch '(#\space #\tab))
(let ((next-idx (add1 src-idx)))
(loop next-idx
(if space?
token-start
src-idx)
next-idx
(if space?
(add1 token-pos)
1)
state
#t
(if (and (not space?)
(> token-end token-start))
(cons (cons (substring str token-start token-end)
token-pos)
res)
res))))
(else
(let ((next-idx (utf8-string-next-char str src-idx)))
(loop next-idx
(if space?
src-idx
token-start)
next-idx
(if space?
1
(add1 token-pos))
state
#f
(if space?
(cons (cons (substring str token-start token-end)
token-pos)
res)
res))))))))))
;; Converts a SGR list into a single string
(define* (sgr-list->string lst
(initial-state empty-sgr-state)
#:reset-state (reset-state #f))
(let loop ((lst lst)
(res '())
(state initial-state))
(if (null? lst)
(string-intersperse
(reverse (if reset-state
(cons reset-state res)
res))
"")
(let ((token (car lst)))
(if (sgr-state? token)
(loop (cdr lst)
(cons (sgr-state-change->string state token) res)
token)
(loop (cdr lst)
(cons (car token) res)
state))))))
;; Predicate for SGR list tokens
(define (sgr-list-token? v)
(and (pair? v)
(string? (car v))
(fixnum? (cdr v))))
;; Returns the length of all utf8 strings in the sgr-list
(define (sgr-list-length sl)
(foldl
(lambda (acc tk)
(if (sgr-list-token? tk)
(+ acc (cdr tk))
acc))
0 sl))
;; Returns the length of all utf8 strings without glues. Glues must
;; have at least width 1 if they are not the first or last
;; token. Those can have zero length. All spaces have width of
;; 1. Used for wrapping blocks.
(define (sgr-list-length/stretch sl)
(let loop ((sl sl)
(len 0)
(seen-string? #f)
(last-space? #f))
(if (null? sl)
(if last-space?
(sub1 len)
len)
(let* ((tk (car sl))
(is-spaces? (sgr-token-spaces? tk))
(is-string? (and (not (sgr-state? tk))
(not is-spaces?))))
(loop (cdr sl)
(cond ((sgr-token-spaces? tk)
(if seen-string?
(add1 len)
len))
((sgr-state? tk)
len)
(else
(+ len (cdr tk))))
(or seen-string?
is-string?)
(if is-string?
#f
(if is-spaces?
#t
last-space?)))))))
;; Returns length without glues
(define (sgr-list-length-w/o-glues sl)
(foldl (lambda (acc tk)
(if (or (sgr-state? tk)
(sgr-token-glue? tk)
(sgr-token-unglue? tk))
acc
(+ acc (cdr tk))))
0 sl))
;; Predicate for string token containing only spaces and tabs
(define (sgr-token-spaces? t)
(and (pair? t)
(string? (car t))
(let loop ((i 0))
(if (= i (cdr t))
#t
(if (memq (string-ref (car t) i) '(#\space #\tab))
(loop (add1 i))
#f)))))
;; Predicate for string token with only spaces and at least one tab
(define (sgr-token-glue? t)
(and (pair? t)
(string? (car t))
(let loop ((i 0)
(glue #f))
(if (= i (cdr t))
glue
(let ((ch (string-ref (car t) i)))
(if (eq? ch #\tab)
(loop (add1 i) #t)
(if (eq? ch #\space)
(loop (add1 i) glue)
#f)))))))
;; Predicate for string containing only a newline
(define (sgr-token-newline? t)
(and (pair? t)
(string? (car t))
(eq? (cdr t) 1)
(eq? (string-ref (car t) 0) #\newline)))
;; Predicate for unglue (used for justify)
(define (sgr-token-unglue? t)
(and (pair? t)
(string? (car t))
(eq? (cdr t) 1)
(eq? (string-ref (car t) 0) #\backspace)))
;; Replaces all occurences of #\tab with #\space and removes trailing
;; #\backspace
(define (sgr-token-neutralize t)
(if (and (pair? t)
(string? (car t)))
(let* ((str (string-copy (car t)))
(len (string-length str)))
(if (> len 0)
(let loop ((idx 0))
(if (= idx len)
(if (eq? (string-ref str (sub1 len)) #\backspace)
(cons (substring str 0 (sub1 len))
(sub1 len))
(cons str len))
(let ((ch (string-ref str idx)))
(when (eq? ch #\tab)
(string-set! str idx #\space))
(loop (add1 idx)))))
t))))
;; Neutralizes whole SGR list
(define (sgr-list-neutralize sl)
(map sgr-token-neutralize sl))
;; Returns the number of glues in given SGR list
(define (sgr-list-num-glues sl)
(foldl (lambda (acc t)
(if (sgr-token-glue? t)
(add1 acc)
acc))
0 sl))
;; Returns the longest word
(define (sgr-list-min-width sl)
(let loop ((sl sl)
(res 0))
(if (null? sl)
res
(let ((tk (car sl)))
(loop (cdr sl)
(if (sgr-state? tk)
res
(max res (cdr tk))))))))
;; Returns the last SGR state in given sgr-list
(define* (sgr-list-last-state sl (initial-state empty-sgr-state))
(let loop ((sl sl)
(state initial-state))
(if (null? sl)
state
(loop (cdr sl)
(if (sgr-state? (car sl))
(car sl)
state)))))
;; Module self-tests
(define (sgr-list-tests!)
(run-tests
sgr-list
(test-equal? sgr-list->string
(sgr-list->string '(("Hello" . 5)))
"Hello")
(test-true sgr-list-token?
(sgr-list-token? '("Hello" . 5)))
(test-false sgr-list-token?
(sgr-list-token? empty-sgr-state))
(test-false sgr-list-token?
(sgr-list-token? (set-sgr-state-foreground
empty-sgr-state
(make-sgr-truecolor 1 2 3))))
(test-equal? sgr-list-length
(sgr-list-length '(("Hello" . 5)))
5)
(test-true sgr-token-spaces?
(sgr-token-spaces? '(" " . 5)))
(test-true sgr-token-spaces?
(sgr-token-spaces? '(" \x09 " . 5)))
(test-false sgr-token-spaces?
(sgr-token-spaces? '(" x " . 5)))
(test-true sgr-token-newline?
(sgr-token-newline? '("\n" . 1)))
(test-false sgr-token-newline?
(sgr-token-newline? '("\na" . 2)))
(test-false sgr-token-newline?
(sgr-token-newline? '("x" . 1)))
(test-true sgr-token-glue?
(sgr-token-glue? '(" \t " . 5)))
(test-true sgr-token-glue?
(sgr-token-glue? '("\t" . 1)))
(test-false sgr-token-glue?
(sgr-token-glue? '(" " . 5)))
(test-false sgr-token-glue?
(sgr-token-glue? '(" x " . 5)))
(test-equal? string->sgr-list
(string->sgr-list "Hello")
'(("Hello" . 5)))
(test-equal? string->sgr-list
(string->sgr-list "\x1b[1mHello \x1b[0mWorld!")
'(1 ("Hello " . 6) 0 ("World!" . 6)))
(test-equal? string->sgr-list/words
(string->sgr-list/words "Hello World!")
'(("Hello" . 5)
(" " . 1)
("World!" . 6)))
(test-equal? string->sgr-list/words
(string->sgr-list/words "\x1b[1mHello \x1b[0mWorld!")
'(1
("Hello" . 5)
(" " . 1)
0
("World!" . 6)))
(test-equal? string->sgr-list/words
(string->sgr-list/words "Hello World!\b")
'(("Hello" . 5)
(" " . 1)
("World!" . 6)
("\b" . 1)))
(test-equal? string->sgr-list/words
(string->sgr-list/words "Hello\nWorld!")
'(("Hello" . 5)
("\n" . 1)
("World!" . 6)))
(test-equal? sgr-list-length/stretch
(sgr-list-length/stretch
'(("Hello" . 5)))
5)
(test-equal? sgr-list-length/stretch
(sgr-list-length/stretch
'(("Hello" . 5) (" " . 4)))
5)
(test-equal? sgr-list-length/stretch
(sgr-list-length/stretch
'(("Hello" . 5) (" " . 4) 1))
5)
(test-equal? sgr-list-length/stretch
(sgr-list-length/stretch
'(1 (" " . 4) ("Hello" . 5) (" " . 4) 1))
5)
(test-equal? sgr-list-length/stretch
(sgr-list-length/stretch
'(("Hello" . 5) (" " . 4) ("World" . 5)))
11)
(test-equal? sgr-list-length-w/o-glues
(sgr-list-length-w/o-glues
'(("Hello" . 5) (" \t " . 5) ("World" . 5)))
10)
(test-true sgr-token-unglue?
(sgr-token-unglue? '("\b" . 1)))
(test-false sgr-token-unglue?
(sgr-token-unglue? '(" \b" . 2)))
(test-equal? sgr-token-neutralize
(sgr-token-neutralize '("Hello\b" . 6))
'("Hello" . 5))
))
)

756
src/sgr-state.scm Normal file
View file

@ -0,0 +1,756 @@
;;
;; sgr-state.scm
;;
;; ECMA-48 Set Graphics Rendition state management.
;;
;; 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-state))
(module
sgr-state
(
sgr-color-valid?
sgr-truecolor?
make-sgr-truecolor
split-sgr-truecolor
make-sgr-state
empty-sgr-state
sgr-state?
sgr-state-intensity
set-sgr-state-intensity
sgr-state-italic
set-sgr-state-italic
sgr-state-underline
set-sgr-state-underline
sgr-state-blink
set-sgr-state-blink
sgr-state-reverse
set-sgr-state-reverse
sgr-state-crossed
set-sgr-state-crossed
sgr-state-foreground
sgr-state-background
set-sgr-state-foreground
set-sgr-state-background
sgr-state-change->string
parse-csi-sgr-sequence+pos
parse-csi-sgr-sequence
update-sgr-state-from-list
update-sgr-state-from-string
sgr-state-tests!
)
(import scheme
(chicken base)
(chicken bitwise)
(chicken string)
testing
racket-kwargs)
;; Checks whether this is indexed color or truecolor representation
;; validating the bit mask as well
(define (sgr-color-valid? c)
(or (< c 256)
(and (>= c #x1000000)
(<= c #x1ffffff))))
;; Returns true if given color is truecolor representation (assumes
;; #x1000000 bit set)
(define (sgr-truecolor? c)
(> c 255))
;; Creates valid truecolor representation
(define (make-sgr-truecolor r g b)
(bitwise-ior #x1000000
(arithmetic-shift (bitwise-and r 255) 16)
(arithmetic-shift (bitwise-and g 255) 8)
(bitwise-and b 255)))
;; Returns the separated RGB alues from SGR truecolor representation
(define (split-sgr-truecolor c)
(values (bitwise-and (arithmetic-shift c -16) 255)
(bitwise-and (arithmetic-shift c -8) 255)
(bitwise-and c 255)))
;; Creates empty SGR state
(define (make-sgr-state)
0)
;; Constant representing empty (default) SGR state
(define empty-sgr-state 0)
;; Returns #t if this is valid SGR state representation
(define (sgr-state? v)
(or (and (fixnum? v)
(= (bitwise-and v (bitwise-not sgr-state-bit-mask)) 0))
(and (pair? v)
(fixnum? (car v))
(= (bitwise-and v (bitwise-not sgr-state-bit-mask)) 0)
(pair? (cdr v))
(or (not (cadr v))
(and (fixnum? (cadr v))
(= (bitwise-and (cadr v) (bitwise-not #x1ffffff)) 0)))
(or (not (cddr v))
(and (fixnum? (cddr v))
(= (bitwise-and (cddr v) (bitwise-not #x1ffffff)) 0))))))
;; Basic SGR state is just a number, extended state is a pair of
;; number and pair of fg/bg truecolors.
(define (sgr-state-bits s)
(if (pair? s)
(car s)
s))
;; Sets the bits part of given SGR state, if it is not a pair, just
;; returns the new bits as state value
(define (set-sgr-state-bits s b)
(if (pair? s)
(cons b (cdr s))
b))
;; Computes positional mask, creates getter and setter for given
;; numeric attribute at given bit-offset
(define-syntax define-sgr-num-attribute
(syntax-rules ()
((_ bit-offset bit-size mask getter setter)
(begin
(define mask (arithmetic-shift (sub1 (arithmetic-shift 1 bit-size))
bit-offset))
(define (getter s)
(let ((v (arithmetic-shift
(bitwise-and (sgr-state-bits s) mask)
(- bit-offset))))
(if (> v 0) v #f)))
(define (setter s vf)
(let ((v (case vf
((#f) 0)
((#t) 1)
(else vf)))
(b (sgr-state-bits s)))
(set-sgr-state-bits
s
(bitwise-ior
(bitwise-and (arithmetic-shift v bit-offset) mask)
(bitwise-and (bitwise-not mask) b)))))))))
;; Wrapper for defining all attributes iteratively, incrementing
;; bit-offset as needed
(define-syntax define-sgr-num-attribute+
(syntax-rules ()
((_ bit-offset total bit-size mask getter setter remaining ...)
(begin
(define-sgr-num-attribute bit-offset bit-size mask getter setter)
(define-sgr-num-attribute+ (+ bit-offset bit-size) total remaining ...)))
((_ bit-offset total)
(define total bit-offset))))
;; Wrapper for definer starting at bit offset 0
(define-syntax define-sgr-num-attributes
(syntax-rules ()
((_ total all ...)
(begin
(define-sgr-num-attribute+ 0 total all ...)))))
;; Define simple (numeric) attributes
(define-sgr-num-attributes
sgr-state-num-bits
;; 1: bold, 2: half-bright
2 sgr-state-intensity-mask sgr-state-intensity set-sgr-state-intensity
1 sgr-state-italic-mask sgr-state-italic set-sgr-state-italic
;; 1: single, 2: double
2 sgr-state-underline-mask sgr-state-underline set-sgr-state-underline
1 sgr-state-blink-mask sgr-state-blink set-sgr-state-blink
1 sgr-state-reverse-mask sgr-state-reverse set-sgr-state-reverse
1 sgr-state-crossed-mask sgr-state-crossed set-sgr-state-crossed
9 sgr-state-fg256-mask sgr-state-fg256 set-sgr-state-fg256
9 sgr-state-bg256-mask sgr-state-bg256 set-sgr-state-bg256)
;; Used in sgr-state? predicate
(define sgr-state-bit-mask (sub1 (arithmetic-shift 1 sgr-state-num-bits)))
;; Returns true, color 0-255 or RGB triplet with bit 17 set to 1 if
;; truecolor
(define (sgr-state-foreground s)
(if (pair? s)
(cadr s)
(let ((c+ (sgr-state-fg256 s)))
(if c+
(bitwise-and c+ 255)
#f))))
;; Returns true, color 0-255 or RGB triplet with bit 17 set to 1 if
;; truecolor
(define (sgr-state-background s)
(if (pair? s)
(cddr s)
(let ((c+ (sgr-state-bg256 s)))
(if c+
(bitwise-and c+ 255)
#f))))
;; Sets foreground color, possibly compacting the SGR state, #f is
;; valid value representing default color
(define (set-sgr-state-foreground s c)
(if (pair? s)
;; Initially it is a pair
(if c
;; Setting some foreground
(if (< c 256)
;; Foreground does not need pair
(if (and (cddr s)
(>= (cddr s) 256))
;; Background needs a pair, set foreground to bits
;; and cadr
(cons (set-sgr-state-fg256 (car s)
(bitwise-ior c 256))
(cons c (cddr s)))
;; Neither background nor foreground need pair,
;; switch to bit-only representation
(set-sgr-state-fg256 (car s) (bitwise-ior c 256)))
;; Foreground needs pair, just update cadr and reset
;; bits
(cons (set-sgr-state-fg256 (car s) 0)
(cons (bitwise-ior c #x1000000)
(cddr s))))
;; Removing foreground
(if (and (cddr s)
(>= (cddr s) 256))
;; Still pair needed for background, store both in bits
;; and cadr
(cons (set-sgr-state-fg256 (car s) 0)
(cons #f (cddr s)))
;; Just reset, no pair for background needed
(set-sgr-state-fg256 s 0)))
;; Initially it is a bit representation
(if c
;; Setting foreground
(if (< c 256)
;; Just set the bits
(set-sgr-state-fg256 s (bitwise-ior c 256))
;; Create pair representation, store exclusively in cadr
(cons (set-sgr-state-fg256 s 0)
(cons (bitwise-ior c #x1000000) #f)))
;; Just clear the bits
(set-sgr-state-fg256 s 0))))
;; Sets background color, possibly compacting the SGR state, #f is
;; valid value representing default color
(define (set-sgr-state-background s c)
(if (pair? s)
;; Initially it is a pair
(if c
;; Setting some background
(if (< c 256)
;; Background does not need pair
(if (and (cadr s)
(>= (cadr s) 256))
;; Foreground needs a pair, set background to bits
;; and cddr
(cons (set-sgr-state-bg256 (car s)
(bitwise-ior c 256))
(cons (cadr s) c))
;; Neither background nor foreground need pair,
;; switch to bit-only representation
(set-sgr-state-bg256 (car s) (bitwise-ior c 256)))
;; Background needs pair, just update cddr and reset
;; bits
(cons (set-sgr-state-bg256 (car s) 0)
(cons (cadr s)
(bitwise-ior c #x1000000))))
;; Removing background
(if (and (cadr s)
(>= (cadr s) 256))
;; Still pair needed for foreground, store both in bits
;; and cddr
(cons (set-sgr-state-bg256 (car s) 0)
(cons (cadr s) #f))
;; Just reset, no pair for foreground needed
(set-sgr-state-bg256 s 0)))
;; Initially it is a bit representation
(if c
;; Setting background
(if (< c 256)
;; Just set the bits
(set-sgr-state-bg256 s (bitwise-ior c 256))
;; Create pair representation, store exclusively in cddr
(cons (set-sgr-state-bg256 s 0)
(cons #f (bitwise-ior c #x1000000))))
;; Just clear the bits
(set-sgr-state-bg256 s 0))))
;; Prepends required CSI SGR sequence for given color change
(define (sgr-prepend-color-change lst color background?)
(let ((off (if background? 10 0)))
(cond ((eq? color #f)
(cons (+ off 39) lst))
((< color 8)
(cons (+ off 30 color) lst))
((< color 16)
(cons (+ off 82 color) lst))
((< color 256)
(cons color
(cons 5
(cons (+ 38 off)
lst))))
(else
(let-values (((r g b) (split-sgr-truecolor color)))
(cons b
(cons g
(cons r
(cons 2
(cons (+ 38 off)
lst))))))))))
;; Produces an CSI SGR sequence to change from the orig state to the
;; next state.
(define (sgr-state-change->string orig next)
(cond
((equal? orig next)
"")
((equal? next empty-sgr-state)
"\x1b[0m")
(else
(let* ((cs0 '())
(cs1 (if (eq? (sgr-state-intensity orig)
(sgr-state-intensity next))
cs0
(cons (case (sgr-state-intensity next)
((1) 1)
((2) 2)
(else 22))
cs0)))
(cs2 (if (eq? (sgr-state-italic orig)
(sgr-state-italic next))
cs1
(cons (if (sgr-state-italic next)
3
23)
cs1)))
(cs3 (if (eq? (sgr-state-underline orig)
(sgr-state-underline next))
cs2
(cons (case (sgr-state-underline next)
((1) 4)
((2) 21)
(else 24))
cs2)))
(cs4 (if (eq? (sgr-state-blink orig)
(sgr-state-blink next))
cs3
(cons (if (sgr-state-blink next)
5
25)
cs3)))
(cs5 (if (eq? (sgr-state-reverse orig)
(sgr-state-reverse next))
cs4
(cons (if (sgr-state-reverse next)
7
27)
cs4)))
(cs6 (if (eq? (sgr-state-crossed orig)
(sgr-state-crossed next))
cs5
(cons (if (sgr-state-crossed next)
9
29)
cs5)))
(cs7 (if (eq? (sgr-state-foreground orig)
(sgr-state-foreground next))
cs6
(sgr-prepend-color-change cs6 (sgr-state-foreground next) #f)))
(cs8 (if (eq? (sgr-state-background orig)
(sgr-state-background next))
cs7
(sgr-prepend-color-change cs7 (sgr-state-background next) #t)))
(cs cs8))
(string-append
"\x1b["
(string-intersperse
(map number->string (reverse cs))
";")
"m")))))
;; Parses a CSI SGR sequence. Returns a list of numeric arguments in
;; the same order as they are present in the sequence, prepends the
;; terminating character (sequence type). Returns position just after
;; parsed sequence as second value.
(define (parse-csi-sgr-sequence+pos str . ps)
(let ((pos (if (null? ps) 0 (car ps)))
(len (string-length str)))
(if (or (>= pos len)
(not (eq? (string-ref str pos) #\x1b)))
(values '() 0)
(if (or (>= (add1 pos) len)
(not (eq? (string-ref str (add1 pos)) #\[)))
(values '() 1)
(let loop ((pos (+ pos 2))
(res '())
(pending #f))
(if (>= pos len)
(values '() pos)
(let ((ch (string-ref str pos)))
(cond ((and (char>=? ch #\0)
(char<=? ch #\9))
(let ((digit (- (char->integer ch)
(char->integer #\0))))
(loop (add1 pos)
res
(if pending
(+ (* pending 10) digit)
digit))))
((eq? ch #\;)
(loop (add1 pos)
(cons pending res)
#f))
(else
(values (cons ch
(reverse (if pending
(cons pending res)
res)))
(add1 pos)))))))))))
;; Parses CSI SGR sequence and returns the sequence list only.
(define (parse-csi-sgr-sequence str . ps)
(let-values (((lst pos)
(parse-csi-sgr-sequence+pos str (if (null? ps) 0 (car ps)))))
lst))
;; Parses 256 and 16M color sequences
(define (parse-extended-sgr-color lst state background?)
(if (null? lst)
(list lst state)
(case (car lst)
((5)
(if (null? (cdr lst))
(list (cdr lst) state)
(list (cddr lst)
(if background?
(set-sgr-state-background state (cadr lst))
(set-sgr-state-foreground state (cadr lst))))))
((2)
(if (null? (cdr lst)) ; R?
(list (cdr lst) state)
(if (null? (cddr lst)) ; G?
(list (cddr lst) state)
(if (null? (cdddr lst)) ; B?
(list (cdddr lst) state)
(list (cddddr lst)
(let ((c (make-sgr-truecolor (cadr lst)
(caddr lst)
(cadddr lst))))
(if background?
(set-sgr-state-background state c)
(set-sgr-state-foreground state c))))))))
(else
(list (cdr lst) state)))))
;; Update given state by parsed SGR state list
(define* (update-sgr-state-from-list state lst
#:default (default empty-sgr-state))
(if (or (null? lst)
(not (eq? (car lst) #\m)))
state
(let loop ((lst (cdr lst))
(state state))
(if (null? lst)
state
(case (car lst)
((0)
(loop (cdr lst)
default))
((1)
(loop (cdr lst)
(set-sgr-state-intensity state 1)))
((2)
(loop (cdr lst)
(set-sgr-state-intensity state 2)))
((3)
(loop (cdr lst)
(set-sgr-state-intensity state #t)))
((4)
(loop (cdr lst)
(set-sgr-state-underline state 1)))
((5)
(loop (cdr lst)
(set-sgr-state-blink state #t)))
((7)
(loop (cdr lst)
(set-sgr-state-reverse state #t)))
((9)
(loop (cdr lst)
(set-sgr-state-crossed state #t)))
((21)
(loop (cdr lst)
(set-sgr-state-underline state 2)))
((22)
(loop (cdr lst)
(set-sgr-state-intensity state #f)))
((23)
(loop (cdr lst)
(set-sgr-state-italic state #f)))
((24)
(loop (cdr lst)
(set-sgr-state-underline state #f)))
((25)
(loop (cdr lst)
(set-sgr-state-blink state #f)))
((27)
(loop (cdr lst)
(set-sgr-state-reverse state #f)))
((29)
(loop (cdr lst)
(set-sgr-state-crossed state #f)))
((30 31 32 33 34 35 36 37)
(loop (cdr lst)
(set-sgr-state-foreground state (- (car lst) 30))))
((38)
(apply loop (parse-extended-sgr-color (cdr lst) state #f)))
((39)
(loop (cdr lst)
(set-sgr-state-foreground state #f)))
((40 41 42 43 44 45 46 47)
(loop (cdr lst)
(set-sgr-state-background state (- (car lst) 40))))
((48)
(apply loop (parse-extended-sgr-color (cdr lst) state #f)))
((49)
(loop (cdr lst)
(set-sgr-state-background state #f)))
((90 91 92 93 94 95 96 97)
(loop (cdr lst)
(set-sgr-state-foreground state (- (car lst) 82))))
((100 101 102 103 104 105 106 107)
(loop (cdr lst)
(set-sgr-state-background state (- (car lst) 92))))
(else
(loop (cdr lst)
state)))))))
;; Updates given SGR state based on ESC sequence(s) given in the
;; string. Optional starting position can be given. Processes only
;; one sequence.
(define* (update-sgr-state-from-string state str
(pos 0)
#:default (default empty-sgr-state))
(let ((lst (parse-csi-sgr-sequence str pos)))
(update-sgr-state-from-list state lst #:default default)))
;; Module self-tests
(define (sgr-state-tests!)
(run-tests
sgr-state
(test-true sgr-color-valid?
(sgr-color-valid? 1))
(test-true sgr-color-valid?
(sgr-color-valid? #x1234567))
(test-false sgr-color-valid?
(sgr-color-valid? 1000))
(test-false sgr-color-valid?
(sgr-color-valid? #x2000000))
(test-false sgr-truecolor?
(sgr-truecolor? 123))
(test-true sgr-truecolor?
(sgr-truecolor? #x1234567))
(test-equal? make-sgr-truecolor
(make-sgr-truecolor 1 2 3)
#x1010203)
(test-equal? split-sgr-truecolor
(call-with-values
(lambda ()
(split-sgr-truecolor #x1112233))
list)
'(17 34 51))
(test-equal? sgr-state-intensity-mask
sgr-state-intensity-mask
3)
(test-equal? sgr-state-italic-mask
sgr-state-italic-mask
4)
(test-equal? sgr-state-italic
(sgr-state-italic 4)
1)
(test-equal? set-sgr-state-italic
(set-sgr-state-italic 0 1)
4)
(test-equal? set-sgr-state-italic
(set-sgr-state-italic 15 0)
11)
(test-equal? set-sgr-state-italic
(set-sgr-state-italic 15 #f)
11)
(test-equal? set-sgr-state-foreground
(set-sgr-state-foreground 0 255)
(set-sgr-state-fg256 0 511))
(test-equal? set-sgr-state-foreground
(set-sgr-state-foreground 0 256)
(cons 0 (cons #x1000100 #f)))
(test-equal? set-sgr-state-foreground
(set-sgr-state-foreground
(set-sgr-state-foreground 0 256) 255)
(set-sgr-state-fg256 0 511))
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-intensity empty-sgr-state 1))
"\x1b[1m")
(test-equal? sgr-state-change->string
(sgr-state-change->string (set-sgr-state-intensity
(set-sgr-state-italic
empty-sgr-state 1) 1)
empty-sgr-state)
"\x1b[0m")
(test-equal? sgr-state-change->string
(sgr-state-change->string (set-sgr-state-intensity
(set-sgr-state-italic
empty-sgr-state #t) 2)
(set-sgr-state-italic
empty-sgr-state #t))
"\x1b[22m")
(test-equal? sgr-state-change->string
(sgr-state-change->string (set-sgr-state-intensity
(set-sgr-state-italic
empty-sgr-state #t) 2)
(set-sgr-state-intensity
empty-sgr-state 2))
"\x1b[23m")
(test-equal? sgr-state-change->string
(sgr-state-change->string (set-sgr-state-intensity
empty-sgr-state 2)
(set-sgr-state-intensity
(set-sgr-state-italic
empty-sgr-state #t) 2))
"\x1b[3m")
(test-equal? sgr-state-change->string
(sgr-state-change->string (set-sgr-state-intensity
empty-sgr-state 2)
(set-sgr-state-intensity
(set-sgr-state-underline
empty-sgr-state 2) 2))
"\x1b[21m")
(test-equal? sgr-state-change->string
(sgr-state-change->string (set-sgr-state-intensity
empty-sgr-state 2)
(set-sgr-state-intensity
(set-sgr-state-blink
empty-sgr-state #t) 2))
"\x1b[5m")
(test-equal? sgr-state-change->string
(sgr-state-change->string (set-sgr-state-intensity
empty-sgr-state 2)
(set-sgr-state-intensity
(set-sgr-state-reverse
empty-sgr-state #t) 2))
"\x1b[7m")
(test-equal? sgr-state-change->string
(sgr-state-change->string (set-sgr-state-intensity
empty-sgr-state 2)
(set-sgr-state-intensity
(set-sgr-state-crossed
empty-sgr-state #t) 2))
"\x1b[9m")
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-foreground
empty-sgr-state
5))
"\x1b[35m")
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-foreground
empty-sgr-state
15))
"\x1b[97m")
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-foreground
empty-sgr-state
115))
"\x1b[38;5;115m")
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-foreground
empty-sgr-state
#x1112233))
"\x1b[38;2;17;34;51m")
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-background
empty-sgr-state
5))
"\x1b[45m")
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-background
empty-sgr-state
15))
"\x1b[107m")
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-background
empty-sgr-state
115))
"\x1b[48;5;115m")
(test-equal? sgr-state-change->string
(sgr-state-change->string empty-sgr-state
(set-sgr-state-background
empty-sgr-state
#x1112233))
"\x1b[48;2;17;34;51m")
(test-equal? parse-csi-sgr-sequence
(parse-csi-sgr-sequence "\x1b[38;2;1;2;3m")
'(#\m 38 2 1 2 3))
(test-equal? update-sgr-state-from-string
(update-sgr-state-from-string
empty-sgr-state
"\x1b[1m")
1)
(test-equal? update-sgr-state-from-string
(update-sgr-state-from-string
empty-sgr-state
"\x1b[31m")
(set-sgr-state-foreground 0 1))
(test-equal? update-sgr-state-from-string
(update-sgr-state-from-string
empty-sgr-state
"\x1b[91m")
(set-sgr-state-foreground 0 9))
(test-equal? update-sgr-state-from-string
(update-sgr-state-from-string
empty-sgr-state
"\x1b[38;2;17;34;51m")
(set-sgr-state-foreground empty-sgr-state #x1112233))
))
)

240
src/table-border.scm Normal file
View 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)))))))
)

208
src/table-processor.scm Normal file
View file

@ -0,0 +1,208 @@
;;
;; table-processor.scm
;;
;; Table data preprocessing (before 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-processor))
(module
table-processor
(
table-prepare
)
(import scheme
(chicken base)
(chicken format)
(chicken sort)
sgr-cell
template-list-expander)
;; Makes the list of lists rectangular, makes sure all cells are
;; sgr-cell (sgr-block actually).
(define (table-prepare-cells tbl)
(let ((width (apply max (map length tbl))))
(map (lambda (row)
(let loop ((row row)
(rrow '())
(rlen 0))
(if (= rlen width)
(let ()
(reverse rrow))
(loop (if (null? row)
row
(cdr row))
(let ((cell (if (null? row)
""
(car row))))
(cons (string->sgr-cell
(if (string? cell)
cell
(format "~A" cell)))
rrow))
(add1 rlen)))))
tbl)))
;; Max from both lists (must be the same length)
(define (combine-column-widths cwidths rwidths)
(let mloop ((cwidths cwidths)
(rwidths rwidths)
(res '()))
(if (null? cwidths)
(reverse res)
(mloop (cdr cwidths)
(cdr rwidths)
(cons (max (car cwidths)
(car rwidths))
res)))))
;; Returns maximum value for each column
(define (table-columns-max-query tbl cell-query)
(if (null? tbl)
'()
(let loop ((widths (map cell-query (car tbl)))
(tbl (cdr tbl)))
(if (null? tbl)
widths
(loop (combine-column-widths widths
(map sgr-cell-min-width (car tbl)))
(cdr tbl))))))
;; Minimal widths
(define (table-min-column-widths tbl)
(table-columns-max-query tbl sgr-cell-min-width))
;; Weights
(define (table-column-weights tbl)
(table-columns-max-query tbl sgr-cell-width))
;; Distribute width according to weights.
(define (compute-weighted-width-adds width weights)
(let ((sorted-weights
(sort
(let loop ((weights weights)
(idx 0)
(res '()))
(if (null? weights)
res
(loop (cdr weights)
(add1 idx)
(cons (cons (car weights)
idx)
res))))
(lambda (a b)
(< (car a)
(car b))))))
(let loop ((weights (map car sorted-weights))
(indexes (map cdr sorted-weights))
(remaining-width width)
(res '()))
(if (null? weights)
(map car
(sort res
(lambda (a b)
(< (cdr a)
(cdr b)))))
(let* ((total-weight (apply + weights))
(this-weight (car weights))
(this-width (quotient (* this-weight remaining-width) total-weight))
(this-index (car indexes)))
(loop (cdr weights)
(cdr indexes)
(- remaining-width this-width)
(cons (cons this-width this-index) res)))))))
;; Sums the two widths
(define (distribute-surplus widths adds)
(let loop ((widths widths)
(adds adds)
(res '()))
(if (null? widths)
(reverse res)
(loop (cdr widths)
(cdr adds)
(cons (+ (car widths)
(car adds))
res)))))
;; For all rows, performs 1st pass render (wrapping)
(define (render-cells-widths tbl widths)
(map (lambda (row)
(let loop ((row row)
(widths widths)
(res '()))
(if (null? row)
(reverse res)
(loop (cdr row)
(cdr widths)
(cons (sgr-cell-render (car row)
#:width (car widths))
res)))))
tbl))
;; Get maximum height, expand using last state and empty rows
(define (expand-row-height row)
(let ((height (apply max (map sgr-cell-height row))))
(map (lambda (cell)
(sgr-cell-vexpand cell height))
row)))
;; Get minimal column widths, combine to minimal wanted widths, get
;; column weights, distribute the surplus (if any). Render all cells
;; to get row heights. Second pass, expand vertically all cells,
;; return result. Widths must be expanded from template spec.
(define (table-prepare tbl width-arg widths-spec)
(if (or (null? tbl)
(null? (car tbl)))
'()
(let* ((ptbl (table-prepare-cells tbl))
;;(_ (print ptbl))
(num-columns (length (car ptbl)))
(widths (expand-template-list widths-spec num-columns))
;;(_ (print widths))
(min-widths0 (table-min-column-widths ptbl))
;;(_ (print min-widths0))
(min-widths (combine-column-widths min-widths0 widths))
;;(_ (print min-widths))
(col-weights (table-column-weights ptbl))
;;(_ (print col-weights))
(min-width (foldl + 0 min-widths))
;;(_ (print min-width))
(width (if (and width-arg
(> width-arg min-width))
width-arg
min-width))
;;(_ (print width))
(width-surplus (- width min-width))
;;(_ (print width-surplus))
(widths-adds (compute-weighted-width-adds width-surplus col-weights))
;;(_ (print widths-adds))
(col-widths (distribute-surplus widths-adds min-widths))
;;(_ (print col-widths))
(tbl1 (render-cells-widths ptbl col-widths))
;;(_ (print tbl1))
(tbl2 (map expand-row-height tbl1)))
;; Just return the result - both the table and cached column widths
(values tbl2
col-widths))))
)

170
src/table-style.scm Normal file
View file

@ -0,0 +1,170 @@
;;
;; table-style.scm
;;
;; Converts and expands table border styles.
;;
;; 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-style))
(module
table-style
(
expand-table-style
table-style-tests!
)
(import scheme
(chicken base)
(chicken keyword)
box-drawing
testing
template-list-expander)
;; Consumes single border specification from cell borders. Returns:
;; sides, line-style-spec and rest.
(define (table-border-style-consume lst)
(let loop ((sides '())
(sides-done? #f)
(line-style-spec '())
(lst lst))
(if (null? lst)
;; Last style in the list, just finish
(values (reverse sides)
(reverse line-style-spec)
lst)
(let ((tk (car lst)))
(cond ((and sides-done?
(keyword? tk))
;; Next side spec continues
(values (reverse sides)
(reverse line-style-spec)
lst))
((keyword? tk)
;; Still adding sides
(loop (cons tk sides)
sides-done? ;; Should be always #f
line-style-spec ;; Should always be '()
(cdr lst)))
(else
;; Line specification
(loop sides
#t
(cons tk line-style-spec)
(cdr lst))))))))
;; Compiles correct box drawing cell and merges it with given cell
(define (combine-cell-border cell sides line-style-spec)
(let ((line-style (spec->line-style line-style-spec)))
;; Overide given sides
(if (null? sides)
(make-line-cell line-style
line-style
line-style
line-style)
(let loop ((sides sides)
(cell cell))
(if (null? sides)
cell
(loop (cdr sides)
(case (car sides)
((#:north #:top #:up) (set-line-cell-north cell line-style))
((#:west #:left) (set-line-cell-west cell line-style))
((#:east #:right) (set-line-cell-east cell line-style))
((#:south #:bottom #:down) (set-line-cell-south cell line-style))
(else cell))))))))
;; Parses border style specification for single cell, returns
;; box-drawing cell with slightly different meaning of NWES sides.
(define (parse-table-cell-border-style spec-arg)
(let ((spec (if (list? spec-arg)
spec-arg
(list spec-arg))))
(let loop ((spec spec)
(cell line-cell-none))
(if (null? spec)
;; Finished, return, whatever we accumulated
cell
(let-values (((sides line-style-spec rest)
(table-border-style-consume spec)))
(loop rest
(combine-cell-border cell sides line-style-spec)))))))
;; Converts all "cells" using parse-table-cell-border-style
(define (compile-table-style-spec spec)
(map (lambda (row)
(if (template-expansion-token? row)
row
(map (lambda (cell)
(if (template-expansion-token? cell)
cell
(parse-table-cell-border-style cell)))
row)))
spec))
;; Converts the template skipping dots, expands the result
(define (expand-table-style spec width height)
(let ((cspec (compile-table-style-spec spec)))
(expand-template-list
(map (lambda (row)
(if (template-expansion-token? row)
row
(expand-template-list row width)))
cspec)
height)))
;; Module self-tests
(define (table-style-tests!)
(run-tests
table-style
(test-equal? parse-table-cell-border-style
(parse-table-cell-border-style 'light)
#b1001100110011001)
(test-equal? parse-table-cell-border-style
(parse-table-cell-border-style '(light dashed))
#b101010101010101)
(test-equal? parse-table-cell-border-style
(parse-table-cell-border-style '(light #:top none))
#b1001100110010000)
(test-equal? compile-table-style-spec
(compile-table-style-spec
'(((heavy dashed) ...)
((light #:left #:right none) ...)
...
(dashed ...)))
'((#b0110011001100110 ...)
(#b1001000000001001 ...)
...
(#b0101010101010101 ...)))
(test-equal? expand-table-style
(expand-table-style
'(((heavy dashed) ...)
((light #:left #:right none) ...)
...
(dashed ...))
4 4)
'((#b0110011001100110 #b0110011001100110 #b0110011001100110 #b0110011001100110)
(#b1001000000001001 #b1001000000001001 #b1001000000001001 #b1001000000001001)
(#b1001000000001001 #b1001000000001001 #b1001000000001001 #b1001000000001001)
(#b0101010101010101 #b0101010101010101 #b0101010101010101 #b0101010101010101)))
))
)

112
src/table.scm Normal file
View file

@ -0,0 +1,112 @@
;;
;; table.scm
;;
;; Table surface API.
;;
;; 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))
(module
table
(
print-table
table->string
table->string-list
table->sgr-lists
)
(import scheme
(chicken base)
(chicken string)
sgr-list
sgr-block
racket-kwargs
table-processor
table-border
table-style)
(define (print-table . args)
(print (apply table->string args)))
(define (table->string . args)
(string-intersperse
(apply table->string-list args)
"\n"))
(define (table->string-list . args)
(map sgr-list->string
(apply table->sgr-lists args)))
(define (merge-rows ptbl borders col-separators unicode?)
(let loop ((rows ptbl)
(borders borders)
(res '()))
(if (null? rows)
(reverse res)
(loop (cdr rows)
(cdr borders)
(cons (table-row-merge (car rows)
col-separators
(car borders)
unicode?)
res)))))
(define* (table->sgr-lists tbl
#:border (border-spec '((none ...) ...))
#:widths (widths-spec '(0 ...))
#:width (width #f)
#:unicode? (unicode? #t))
(let-values (((ptbl col-widths)
(table-prepare tbl width widths-spec)))
(let* ((num-columns (length (car tbl)))
(num-rows (length tbl))
(borders (expand-table-style border-spec num-columns num-rows))
(col-separators (table-col-separators? borders))
(rows (merge-rows ptbl borders col-separators unicode?)))
(let loop ((rows rows)
(borders borders)
(res '())
(prev-borders #f))
(if (null? rows)
(apply append
(reverse (if (table-border-between-rows? prev-borders #f)
(cons (table-rows-border col-widths
prev-borders
#f
col-separators
unicode?)
res)
res)))
(loop (cdr rows)
(cdr borders)
(if (table-border-between-rows? prev-borders (car borders))
(cons (car rows)
(cons (table-rows-border col-widths
prev-borders
(car borders)
col-separators
unicode?)
res))
(cons (car rows) res))
(car borders)
))))))
)

153
src/template-list-expander.scm Normal file
View file

@ -0,0 +1,153 @@
;;
;; template-list-expander.scm
;;
;; Dynamic length lists based on simple templates with head and tail
;; patterns.
;;
;; 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 template-list-expander))
(module
template-list-expander
(
template-expansion-token?
expand-template-list
template-list-expander-tests!
)
(import scheme
(chicken base)
testing)
(define (template-expansion-token? token)
(and (symbol? token)
(let* ((tokenstr (symbol->string token))
(tokenlen (string-length tokenstr)))
(and (>= tokenlen 3)
(string=? (substring tokenstr 0 3) "...")))))
(define (split-template-list temp-lst)
(let loop ((lst temp-lst)
(rhead '()))
(if (null? lst)
(values temp-lst '() '())
(let* ((token (car lst))
(tokenstr (if (symbol? token)
(symbol->string token)
""))
(tokenlen (if (symbol? token)
(string-length tokenstr)
0)))
(cond ((and (symbol? token)
(>= tokenlen 3)
(string=? (substring tokenstr 0 3) "..."))
(let rloop ((cnt (- tokenlen 2))
(rhead2 rhead)
(rrep '()))
(if (= cnt 0)
(values (reverse rhead2)
rrep
(cdr lst))
(rloop (sub1 cnt)
(cdr rhead2)
(cons (car rhead2) rrep)))))
(else
(loop (cdr lst)
(cons token rhead))))))))
(define (repeat-list-for lst len)
(let loop ((cnt len)
(rep lst)
(res '()))
(if (= cnt 0)
(reverse res)
(loop (sub1 cnt)
(if (null? (cdr rep)) lst (cdr rep))
(cons (car rep) res)))))
(define (take-from-list lst cnt)
(let loop ((lst lst)
(res '())
(cnt cnt))
(if (= cnt 0)
(reverse res)
(loop (cdr lst)
(cons (car lst) res)
(sub1 cnt)))))
(define (expand-template-list lst len)
(let-values (((head rep tail) (split-template-list lst)))
(let ((headlen (length head))
(taillen (length tail)))
;;(print "----------------")
;;(print "head = " head)
;;(print "rep = " rep)
;;(print "tail = " tail)
(cond
((= len headlen)
head)
((< len headlen)
(take-from-list head len))
(else
(let ((head+taillen (+ headlen taillen)))
(cond
((= len head+taillen)
(append head tail))
((< len head+taillen)
(append head (take-from-list tail (- len head+taillen))))
(else
(append head
(repeat-list-for rep (- len head+taillen))
tail)))))))))
(define (template-list-expander-tests!)
(run-tests
template-list-expander
(test-equal? expand-template-list
(expand-template-list '() 0)
'())
(test-equal? expand-template-list
(expand-template-list '((a) ... (b)) 5)
'((a) (a) (a) (a) (b)))
(test-equal? expand-template-list
(expand-template-list '((c) (a) (d) ... (b) (e)) 9)
'((c) (a) (d) (d) (d) (d) (d) (b) (e)))
(test-equal? expand-template-list
(expand-template-list '((c) (a) (d) .... (b) (e)) 9)
'((c) (a) (d) (a) (d) (a) (d) (b) (e)))
(test-true template-expansion-token?
(template-expansion-token? '...))
(test-true template-expansion-token?
(template-expansion-token? '....))
(test-false template-expansion-token?
(template-expansion-token? '..))
(test-false template-expansion-token?
(template-expansion-token? 'hello))
(test-false template-expansion-token?
(template-expansion-token? "hello"))
(test-equal? expand-template-list
(expand-template-list '(a b ... c) 2)
'(a c))
))
)

305
src/util-utf8.scm Normal file
View file

@ -0,0 +1,305 @@
;;
;; util-utf8.scm
;;
;; UTF-8 support
;;
;; 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 util-utf8))
(module
util-utf8
(
utf8-char->string
make-utf8-string
string-append-utf8-char
utf8-string->lists
utf8-bytes->lists
utf8-string-length
utf8-string-next-char
utf8-string->list
list->utf8-string
util-utf8-tests!
)
(import scheme
(chicken base)
(chicken bitwise)
testing)
;; Encodes given character as UTF-8
(define (utf8-char->string ch)
(let ((n (char->integer ch)))
(cond ((>= n #x10000)
(let ((r (make-string 4))
(b0 (bitwise-and n #b111111))
(b1 (bitwise-and (arithmetic-shift n -6) #b111111))
(b2 (bitwise-and (arithmetic-shift n -12) #b111111))
(b3 (bitwise-and (arithmetic-shift n -18) #b111)))
(string-set! r 0 (integer->char (bitwise-ior b3 #b11110000)))
(string-set! r 1 (integer->char (bitwise-ior b2 #b10000000)))
(string-set! r 2 (integer->char (bitwise-ior b1 #b10000000)))
(string-set! r 3 (integer->char (bitwise-ior b0 #b10000000)))
r))
((>= n #x800)
(let ((r (make-string 3))
(b0 (bitwise-and n #b111111))
(b1 (bitwise-and (arithmetic-shift n -6) #b111111))
(b2 (bitwise-and (arithmetic-shift n -12) #b1111)))
(string-set! r 0 (integer->char (bitwise-ior b2 #b11100000)))
(string-set! r 1 (integer->char (bitwise-ior b1 #b10000000)))
(string-set! r 2 (integer->char (bitwise-ior b0 #b10000000)))
r))
((>= n #x80)
(let ((r (make-string 2))
(b0 (bitwise-and n #b111111))
(b1 (bitwise-and (arithmetic-shift n -6) #b11111)))
(string-set! r 0 (integer->char (bitwise-ior b1 #b11000000)))
(string-set! r 1 (integer->char (bitwise-ior b0 #b10000000)))
r))
(else
(make-string 1 ch)))))
;; UTF-8 version of make-string
(define (make-utf8-string n . chs)
(let* ((ch (if (null? chs) #\space (car chs)))
(s (utf8-char->string ch))
(sl (string-length s))
(rl (* n sl))
(r (make-string rl)))
(let loop ((ri 0)
(si 0))
(if (= ri rl)
r
(let ((nsi (add1 si)))
(string-set! r ri (string-ref s si))
(loop (add1 ri)
(if (= nsi sl) 0 nsi)))))))
;; UTF-8 character append
(define (string-append-utf8-char s ch)
(string-append s (utf8-char->string ch)))
;; Converts a UTF-8 string into two lists: list of UTF-8 characters
;; of the string and a list of remaining bytes (as integers).
(define (utf8-string->lists str)
(utf8-bytes->lists
(map char->integer
(string->list str))))
;; The same as above but accepts a list of bytes (as integers)
(define (utf8-bytes->lists chars)
(let loop ((bytes chars)
(rpending '())
(pending 0)
(expected #f)
(res '()))
(if (null? bytes)
(values (reverse res)
(reverse rpending))
(let ((byte (car bytes)))
(cond (expected
;; Decode UTF-8 sequence
(cond ((= expected 1)
;; Last byte
(let ((char (integer->char (bitwise-ior pending
(bitwise-and byte #b111111)))))
(loop (cdr bytes)
'()
0
#f
(cons char res))))
(else
;; Intermediate bytes
(loop (cdr bytes)
(cons byte rpending)
(arithmetic-shift (bitwise-ior pending
(bitwise-and byte #b111111)) 6)
(sub1 expected)
res))))
(else
;; ASCII or first of UTF-8 sequence
(cond ((= (bitwise-and byte #b10000000) 0)
;; ASCII
(loop (cdr bytes)
'()
0
#f
(cons (integer->char byte) res)))
(else
;; First byte of UTF-8 sequence
(let-values
(((first-byte char-bytes)
(cond ((= (bitwise-and byte #b11000000) #b11000000)
(values (bitwise-and byte #b11111)
2))
((= (bitwise-and byte #b11100000) #b11100000)
(values (bitwise-and byte #b1111)
3))
((= (bitwise-and byte #b11110000) #b11110000)
(values (bitwise-and byte #b111)
4)))))
(loop (cdr bytes)
(list byte)
(arithmetic-shift first-byte 6)
(sub1 char-bytes)
res))))))))))
;; Returns the position right after the character at specified
;; position.
(define (utf8-string-next-char str . sis)
(let ((len (string-length str))
(si0 (if (null? sis) 0 (car sis))))
(let loop ((si si0)
(pc 0))
(if (or (= si len)
(and (> si si0)
(eq? pc 0)))
si
(let ((b (char->integer (string-ref str si))))
(loop (add1 si)
(if (= pc 0)
(if (= (bitwise-and b #b11111000) #b11110000)
3
(if (= (bitwise-and b #b11110000) #b11100000)
2
(if (= (bitwise-and b 128) 128)
1
0)))
(if (= (bitwise-and b 128) 128)
(sub1 pc)
0))))))))
;; Calculates the length of given UTF-8 string
(define (utf8-string-length s)
(let ((l (string-length s)))
(let loop ((si 0)
(ci 0)
(pc 0))
(if (= si l)
ci
(let ((b (char->integer (string-ref s si))))
(loop (add1 si)
(if (or (= pc 0)
(= (bitwise-and b 128) 0))
(add1 ci)
ci)
(if (= pc 0)
(if (= (bitwise-and b #b11111000) #b11110000)
3
(if (= (bitwise-and b #b11110000) #b11100000)
2
(if (= (bitwise-and b 128) 128)
1
0)))
(if (= (bitwise-and b 128) 128)
(sub1 pc)
0))))))))
;; Converts utf8 string to list of unicode characters
(define (utf8-string->list s)
(let-values (((lst _) (utf8-string->lists s)))
lst))
;; Prepends 1-byte characters representing utf8 encoding of given
;; unicode character to the list
(define (prepend-unicode-char-to-utf8-list ch lst)
(let ((n (char->integer ch)))
(cond ((>= n #x10000)
(let ((r (make-string 4))
(b0 (bitwise-and n #b111111))
(b1 (bitwise-and (arithmetic-shift n -6) #b111111))
(b2 (bitwise-and (arithmetic-shift n -12) #b111111))
(b3 (bitwise-and (arithmetic-shift n -18) #b111)))
(cons (integer->char (bitwise-ior b0 #b10000000))
(cons (integer->char (bitwise-ior b1 #b10000000))
(cons (integer->char (bitwise-ior b2 #b10000000))
(cons (integer->char (bitwise-ior b3 #b11110000))
lst))))))
((>= n #x800)
(let ((r (make-string 3))
(b0 (bitwise-and n #b111111))
(b1 (bitwise-and (arithmetic-shift n -6) #b111111))
(b2 (bitwise-and (arithmetic-shift n -12) #b1111)))
(cons (integer->char (bitwise-ior b0 #b10000000))
(cons (integer->char (bitwise-ior b1 #b10000000))
(cons (integer->char (bitwise-ior b2 #b11100000))
lst)))))
((>= n #x80)
(let ((r (make-string 2))
(b0 (bitwise-and n #b111111))
(b1 (bitwise-and (arithmetic-shift n -6) #b11111)))
(cons (integer->char (bitwise-ior b0 #b10000000))
(cons (integer->char (bitwise-ior b1 #b11000000))
lst))))
(else
(cons ch lst)))))
;; Converts list of unicode characters into utf8 string
(define (list->utf8-string lst)
(let loop ((lst lst)
(res '()))
(if (null? lst)
(list->string (reverse res))
(loop (cdr lst)
(prepend-unicode-char-to-utf8-list (car lst) res)))))
;; Module self-tests
(define (util-utf8-tests!)
(run-tests
util-utf8
(test-equal? utf8-char->string
(utf8-char->string #\ř)
"ř")
(test-equal? make-utf8-string
(make-utf8-string 4 #\č)
"čččč")
(test-equal? string-append-utf8-char
(string-append-utf8-char "ččč" #\ř)
"čččř")
(test-equal? utf8-string->list
(utf8-string->list "ěščř")
'(#\ě #\š #\č #\ř))
(test-equal? list->utf8-string
(list->utf8-string '(#\ě #\š #\č #\ř))
"ěščř")
(test-equal? utf8-string-length
(utf8-string-length "ěščř")
4)
(test-equal? utf8-string-length
(utf8-string-length "ěxšy")
4)
(test-equal? utf8-string-next-char
(utf8-string-next-char "ěščř")
2)
(test-equal? utf8-string-next-char
(utf8-string-next-char "ěščř" 2)
4)
))
)