Import new table renderer.

src/table.scm

@@ -0,0 +1,112 @@
+;;
+;; table.scm
+;;
+;; Table surface API.
+;;
+;; ISC License
+;;
+;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(declare (unit table))
+
+(module
+ table
+ (
+  print-table
+  table->string
+  table->string-list
+  table->sgr-lists
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken string)
+	 sgr-list
+	 sgr-block
+	 racket-kwargs
+	 table-processor
+	 table-border
+	 table-style)
+
+ (define (print-table . args)
+   (print (apply table->string args)))
+
+ (define (table->string . args)
+   (string-intersperse
+    (apply table->string-list args)
+    "\n"))
+
+ (define (table->string-list . args)
+   (map sgr-list->string
+	(apply table->sgr-lists args)))
+
+ (define (merge-rows ptbl borders col-separators unicode?)
+   (let loop ((rows ptbl)
+	      (borders borders)
+	      (res '()))
+     (if (null? rows)
+	 (reverse res)
+	 (loop (cdr rows)
+	       (cdr borders)
+	       (cons (table-row-merge (car rows)
+				      col-separators
+				      (car borders)
+				      unicode?)
+		     res)))))
+
+ (define* (table->sgr-lists tbl
+			    #:border (border-spec '((none ...) ...))
+			    #:widths (widths-spec '(0 ...))
+			    #:width (width #f)
+			    #:unicode? (unicode? #t))
+   (let-values (((ptbl col-widths)
+		 (table-prepare tbl width widths-spec)))
+     (let* ((num-columns (length (car tbl)))
+	    (num-rows (length tbl))
+	    (borders (expand-table-style border-spec num-columns num-rows))
+	    (col-separators (table-col-separators? borders))
+	    (rows (merge-rows ptbl borders col-separators unicode?)))
+       (let loop ((rows rows)
+		  (borders borders)
+		  (res '())
+		  (prev-borders #f))
+	 (if (null? rows)
+	     (apply append
+		    (reverse (if (table-border-between-rows? prev-borders #f)
+				 (cons (table-rows-border col-widths
+							  prev-borders
+							  #f
+							  col-separators
+							  unicode?)
+				       res)
+				 res)))
+	     (loop (cdr rows)
+		   (cdr borders)
+		   (if (table-border-between-rows? prev-borders (car borders))
+		       (cons (car rows)
+			     (cons (table-rows-border col-widths
+						      prev-borders
+						      (car borders)
+						      col-separators
+						      unicode?)
+				   res))
+		       (cons (car rows) res))
+		   (car borders)
+		   ))))))
+
+ )