Import new table renderer.

src/table-processor.scm

@@ -0,0 +1,208 @@
+;;
+;; table-processor.scm
+;;
+;; Table data preprocessing (before rendering)
+;;
+;; ISC License
+;;
+;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(declare (unit table-processor))
+
+(module
+ table-processor
+ (
+  table-prepare
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken format)
+	 (chicken sort)
+	 sgr-cell
+	 template-list-expander)
+
+ ;; Makes the list of lists rectangular, makes sure all cells are
+ ;; sgr-cell (sgr-block actually).
+ (define (table-prepare-cells tbl)
+   (let ((width (apply max (map length tbl))))
+     (map (lambda (row)
+	    (let loop ((row row)
+		       (rrow '())
+		       (rlen 0))
+	      (if (= rlen width)
+		  (let ()
+		    (reverse rrow))
+		  (loop (if (null? row)
+			    row
+			    (cdr row))
+			(let ((cell (if (null? row)
+					""
+					(car row))))
+			  (cons (string->sgr-cell
+				 (if (string? cell)
+				     cell
+				     (format "~A" cell)))
+				rrow))
+			(add1 rlen)))))
+	  tbl)))
+
+ ;; Max from both lists (must be the same length)
+ (define (combine-column-widths cwidths rwidths)
+   (let mloop ((cwidths cwidths)
+	       (rwidths rwidths)
+	       (res '()))
+     (if (null? cwidths)
+	 (reverse res)
+	 (mloop (cdr cwidths)
+		(cdr rwidths)
+		(cons (max (car cwidths)
+			   (car rwidths))
+		      res)))))
+
+ ;; Returns maximum value for each column
+ (define (table-columns-max-query tbl cell-query)
+   (if (null? tbl)
+       '()
+       (let loop ((widths (map cell-query (car tbl)))
+		  (tbl (cdr tbl)))
+	 (if (null? tbl)
+	     widths
+	     (loop (combine-column-widths widths
+					  (map sgr-cell-min-width (car tbl)))
+		   (cdr tbl))))))
+
+ ;; Minimal widths
+ (define (table-min-column-widths tbl)
+   (table-columns-max-query tbl sgr-cell-min-width))
+
+ ;; Weights
+ (define (table-column-weights tbl)
+   (table-columns-max-query tbl sgr-cell-width))
+
+ ;; Distribute width according to weights.
+ (define (compute-weighted-width-adds width weights)
+   (let ((sorted-weights
+	  (sort
+	   (let loop ((weights weights)
+		      (idx 0)
+		      (res '()))
+	     (if (null? weights)
+		 res
+		 (loop (cdr weights)
+		       (add1 idx)
+		       (cons (cons (car weights)
+				   idx)
+			     res))))
+	   (lambda (a b)
+	     (< (car a)
+		(car b))))))
+     (let loop ((weights (map car sorted-weights))
+		(indexes (map cdr sorted-weights))
+		(remaining-width width)
+		(res '()))
+       (if (null? weights)
+	   (map car
+		(sort res
+		      (lambda (a b)
+			(< (cdr a)
+			   (cdr b)))))
+	   (let* ((total-weight (apply + weights))
+		  (this-weight (car weights))
+		  (this-width (quotient (* this-weight remaining-width) total-weight))
+		  (this-index (car indexes)))
+	     (loop (cdr weights)
+		   (cdr indexes)
+		   (- remaining-width this-width)
+		   (cons (cons this-width this-index) res)))))))
+
+ ;; Sums the two widths
+ (define (distribute-surplus widths adds)
+   (let loop ((widths widths)
+	      (adds adds)
+	      (res '()))
+     (if (null? widths)
+	 (reverse res)
+	 (loop (cdr widths)
+	       (cdr adds)
+	       (cons (+ (car widths)
+			(car adds))
+		     res)))))
+
+ ;; For all rows, performs 1st pass render (wrapping)
+ (define (render-cells-widths tbl widths)
+   (map (lambda (row)
+	  (let loop ((row row)
+		     (widths widths)
+		     (res '()))
+	    (if (null? row)
+		(reverse res)
+		(loop (cdr row)
+		      (cdr widths)
+		      (cons (sgr-cell-render (car row)
+					     #:width (car widths))
+			    res)))))
+	tbl))
+
+ ;; Get maximum height, expand using last state and empty rows
+ (define (expand-row-height row)
+   (let ((height (apply max (map sgr-cell-height row))))
+     (map (lambda (cell)
+	    (sgr-cell-vexpand cell height))
+	  row)))
+
+ ;; Get minimal column widths, combine to minimal wanted widths, get
+ ;; column weights, distribute the surplus (if any). Render all cells
+ ;; to get row heights. Second pass, expand vertically all cells,
+ ;; return result. Widths must be expanded from template spec.
+ (define (table-prepare tbl width-arg widths-spec)
+   (if (or (null? tbl)
+	   (null? (car tbl)))
+       '()
+       (let* ((ptbl (table-prepare-cells tbl))
+	      ;;(_ (print ptbl))
+	      (num-columns (length (car ptbl)))
+	      (widths (expand-template-list widths-spec num-columns))
+	      ;;(_ (print widths))
+	      (min-widths0 (table-min-column-widths ptbl))
+	      ;;(_ (print min-widths0))
+	      (min-widths (combine-column-widths min-widths0 widths))
+	      ;;(_ (print min-widths))
+	      (col-weights (table-column-weights ptbl))
+	      ;;(_ (print col-weights))
+	      (min-width (foldl + 0 min-widths))
+	      ;;(_ (print min-width))
+	      (width (if (and width-arg
+			      (> width-arg min-width))
+			 width-arg
+			 min-width))
+	      ;;(_ (print width))
+	      (width-surplus (- width min-width))
+	      ;;(_ (print width-surplus))
+	      (widths-adds (compute-weighted-width-adds width-surplus col-weights))
+	      ;;(_ (print widths-adds))
+	      (col-widths (distribute-surplus widths-adds min-widths))
+	      ;;(_ (print col-widths))
+	      (tbl1 (render-cells-widths ptbl col-widths))
+	      ;;(_ (print tbl1))
+	      (tbl2 (map expand-row-height tbl1)))
+	 ;; Just return the result - both the table and cached column widths
+	 (values tbl2
+		 col-widths))))
+
+ )