diff --git a/src/Makefile b/src/Makefile index 3bfa127..83a5756 100644 --- a/src/Makefile +++ b/src/Makefile @@ -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-proc.o util-mail.o notifications.o util-format.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 imports: $(HACKERBASE-DEPS) @@ -389,3 +392,70 @@ util-dict-bst.import.scm: $(UTIL-DICT-BST-SOURCES) RACKET-KWARGS-SOURCES=racket-kwargs.scm 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) diff --git a/src/box-drawing.scm b/src/box-drawing.scm new file mode 100644 index 0000000..6348110 --- /dev/null +++ b/src/box-drawing.scm @@ -0,0 +1,765 @@ +;; +;; box-drawing.scm +;; +;; Unicode box drawing combiners. +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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) + )) + + ) diff --git a/src/sgr-block.scm b/src/sgr-block.scm new file mode 100644 index 0000000..0f6ca22 --- /dev/null +++ b/src/sgr-block.scm @@ -0,0 +1,527 @@ +;; +;; sgr-block.scm +;; +;; Represents a block of sgr-list rows. +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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))) + )) + + ) diff --git a/src/sgr-cell.scm b/src/sgr-cell.scm new file mode 100644 index 0000000..549d8ae --- /dev/null +++ b/src/sgr-cell.scm @@ -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 +;; +;; 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) + + ) diff --git a/src/sgr-list.scm b/src/sgr-list.scm new file mode 100644 index 0000000..d5c4cfb --- /dev/null +++ b/src/sgr-list.scm @@ -0,0 +1,485 @@ +;; +;; sgr-list.scm +;; +;; Intermediate representation of strings with SGR state changes. +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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)) + )) + + ) diff --git a/src/sgr-state.scm b/src/sgr-state.scm new file mode 100644 index 0000000..27dbf06 --- /dev/null +++ b/src/sgr-state.scm @@ -0,0 +1,756 @@ +;; +;; sgr-state.scm +;; +;; ECMA-48 Set Graphics Rendition state management. +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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)) + )) + + ) diff --git a/src/table-border.scm b/src/table-border.scm new file mode 100644 index 0000000..9618633 --- /dev/null +++ b/src/table-border.scm @@ -0,0 +1,240 @@ +;; +;; table-border.scm +;; +;; Table border rendering. +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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))))))) + + ) diff --git a/src/table-processor.scm b/src/table-processor.scm new file mode 100644 index 0000000..53eb8d2 --- /dev/null +++ b/src/table-processor.scm @@ -0,0 +1,208 @@ +;; +;; table-processor.scm +;; +;; Table data preprocessing (before rendering) +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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)))) + + ) diff --git a/src/table-style.scm b/src/table-style.scm new file mode 100644 index 0000000..beed884 --- /dev/null +++ b/src/table-style.scm @@ -0,0 +1,170 @@ +;; +;; table-style.scm +;; +;; Converts and expands table border styles. +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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))) + )) + + ) diff --git a/src/table.scm b/src/table.scm new file mode 100644 index 0000000..6de8e39 --- /dev/null +++ b/src/table.scm @@ -0,0 +1,112 @@ +;; +;; table.scm +;; +;; Table surface API. +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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) + )))))) + + ) diff --git a/src/template-list-expander.scm b/src/template-list-expander.scm new file mode 100644 index 0000000..4758ae5 --- /dev/null +++ b/src/template-list-expander.scm @@ -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 +;; +;; 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)) + )) + + ) diff --git a/src/util-utf8.scm b/src/util-utf8.scm new file mode 100644 index 0000000..ed08f6c --- /dev/null +++ b/src/util-utf8.scm @@ -0,0 +1,305 @@ +;; +;; util-utf8.scm +;; +;; UTF-8 support +;; +;; ISC License +;; +;; Copyright 2023 Dominik Pantůček +;; +;; 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) + )) + + )