;;
;; table-border.scm
;;
;; Table border 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-border))

(module
 table-border
 (
  table-rows-border

  make-table-vertical-sgr-block

  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)))))))

 ;; Universal block maker
 (define (make-table-vertical-sgr-block height str)
   (let loop ((height height)
	      (res '()))
     (if (= height 0)
	 res
	 (loop (sub1 height)
	       (cons (list 0 (cons str 1))
		     res)))))

 ;; 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)))
     (make-table-vertical-sgr-block height str)))

 ;; 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)))))))

 )