hackerbase/src/table-processor.scm

;;
;; 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 cell-query (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)))
       (values '() '())
       (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)) ;; Also ideal widths
	      ;;(_ (print col-weights))
	      (min-width (foldl + 0 min-widths))
	      (max-width (foldl + 0 col-weights))
	      ;;(_ (print min-width))
	      (width (if (and width-arg
			      (> width-arg min-width))
			 width-arg
			 max-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 (if width-arg
			      (distribute-surplus widths-adds min-widths)
			      col-weights))
	      ;;(_ (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))))

 )