diff --git a/table.scm b/table.scm new file mode 100644 index 0000000..5b3dc16 --- /dev/null +++ b/table.scm @@ -0,0 +1,119 @@ +;; +;; table.scm +;; +;; Simple table formatter. +;; +;; ISC License +;; +;; Copyright 2023 Brmlab, z.s. +;; 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 + ( + table-tests! + ) + + (import scheme + (chicken base) + (chicken string) + (chicken format) + ansi + testing) + + ;; Returns a list of strings representing the rows in the original + ;; string. + (define (string->rows str) + (string-split str "\n" #t)) + + ;; Creates procedure that ensures a row has given number of elements + ;; filling the missing elements with given filler (defaults to empty + ;; string). + (define ((make-row-extender ds . ofl) row) + (let ((fl (if (null? ofl) "" (car ofl)))) + (let ((rs (length row))) + (if (< rs ds) + (let loop ((rrow (reverse row)) + (rs rs)) + (if (eq? rs ds) + (reverse rrow) + (loop (cons fl rrow) + (add1 rs)))) + row)))) + + ;; Accepts list of lists and makes sure all rows contain the same + ;; number of elements using empty strings as filler. + (define (table-rectangularize tbl) + (let ((mrl (apply max (map length tbl)))) + (map (make-row-extender mrl) tbl))) + + ;; Accepts list of lists of anything and returns a list of lists of + ;; strings. + (define (table-stringify tbl) + (map + (lambda (r) + (map (lambda (c) (sprintf "~A" c)) r)) + tbl)) + + ;; Converts a 2D table - list of list of strings - into a table of + ;; cell lists with cell text lines. + (define (table-prepare-cells tbl) + (map + (lambda (r) + (map string->rows r)) + tbl)) + + ;; Ensures the table is rectangular and each cell is a list of strings. + (define (table-prepare tbl) + (table-prepare-cells + (table-stringify + (table-rectangularize tbl)))) + + (define (table->string tbl . args) + "") + + ;; Performs module self-tests + (define (table-tests!) + (run-tests + table + (test-equal? string->rows (string->rows "asdf") '("asdf")) + (test-equal? string->rows (string->rows "asdf\nqwer") '("asdf" "qwer")) + (test-equal? string->rows (string->rows "\nasdf\nqwer") '("" "asdf" "qwer")) + (test-equal? make-row-extender + ((make-row-extender 5) '("test")) + '("test" "" "" "" "")) + (test-equal? make-row-extender + ((make-row-extender 5 "x") '("test")) + '("test" "x" "x" "x" "x")) + (test-equal? table-rectangularize + (table-rectangularize '(("x" "y" "z") ("a" "b") ("1" "2" "3" "4"))) + '(("x" "y" "z" "") ("a" "b" "" "") ("1" "2" "3" "4"))) + (test-equal? table-stringify + (table-stringify '((1 2 3) (a b c) ("d"))) + '(("1" "2" "3") ("a" "b" "c") ("d"))) + (test-equal? table-prepare-cells + (table-prepare-cells '(("x" "y" "z" "") ("a" "b" "" "") ("1" "2" "3" "4"))) + '((("x") ("y") ("z") ("")) (("a") ("b") ("") ("")) (("1") ("2") ("3") ("4")))) + )) + + ) + +(import table) +(table-tests!)