;;
;; sgr-block.scm
;;
;; Represents a block of sgr-list rows.
;;
;; 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 sgr-block))

(module
 sgr-block
 (
  sgr-list->sgr-block

  sgr-block->string-list

  sgr-block-width
  sgr-block-height

  sgr-line-render
  sgr-block-render

  sgr-block-vexpand

  sgr-block-happend

  sgr-block-tests!
  )

 (import scheme
	 (chicken base)
	 racket-kwargs
	 sgr-state
	 sgr-list
	 testing
	 util-utf8)

 ;; Converts sgr-list (possibly containing multiple lines) into a
 ;; sgr-block
 (define* (sgr-list->sgr-block sl
			       (initial-state empty-sgr-state))
   (let loop ((sl sl)
	      (state initial-state)
	      (row '())
	      (res '()))
     (if (null? sl)
	 (reverse (if (null? row)
		      res
		      (cons (reverse row) res)))
	 (let ((token (car sl)))
	   (cond
	    ((sgr-token-newline? token)
	     (loop (cdr sl)
		   state
		   (list state)
		   (cons (reverse row) res)))
	    ((sgr-state? token)
	     (loop (cdr sl)
		   token
		   (if (or (null? row)
			   (not (sgr-state? (car row))))
		       (cons token row)
		       (cons token (cdr row)))
		   res))
	    (else
	     (loop (cdr sl)
		   state
		   (cons token row)
		   res)))))))

 ;; Creates a plain list of strings from given block
 (define* (sgr-block->string-list sb
				  #:reset-state (reset-state #f)
				  #:strip-ansi? (strip-ansi? #f))
   (map (lambda (sl)
	  (sgr-list->string sl
			    #:reset-state reset-state
			    #:strip-ansi? strip-ansi?))
	sb))

 ;; Returns the width of the longest SGR line in the block
 (define (sgr-block-width sb)
   (apply max (map sgr-list-length/stretch sb)))

 ;; Returns the number of SGR lines in the block
 (define (sgr-block-height sb)
   (length sb))

 ;; Creates filler for justification of SGR lines
 (define (make-sgr-list-filler n)
   (cons (make-utf8-string n #\xA0) n))

 ;; If first or last non-sgr-state token is space, removes it,
 ;; converts all spaces to glues. Removes unglue.
 (define (sgr-line-preprocess sl justify?)
   (let loop ((sl sl)
	      (res '())
	      (content? #f))
     (if (null? sl)
	 (if (and (not (null? res))
		  (sgr-token-spaces? (car res)))
	     (reverse (cdr res))
	     (if (and (not (null? res))
		      (not (null? (cdr res)))
		      (sgr-state? (car res))
		      (sgr-token-spaces? (cadr res)))
		 (reverse (cons (car res)
				(cddr res)))
		 (reverse res)))
	 (let ((t (car sl)))
	   (loop (cdr sl)
		 (if (sgr-token-spaces? t)
		     (if content?
			 (cons (if justify?
				   (cons "\t" 1)
				   t)
			       res)
			 res)
		     (if (sgr-token-unglue? t)
			 res
			 (cons t res)))
		 (or content?
		     (and (not (sgr-token-spaces? t))
			  (not (sgr-token-unglue? t)))))))))

 ;; Splits the remaining evenly prefering first and last
 (define (compute-glue-lens num-glues remaining)
   (let loop ((num num-glues)
	      (remaining remaining)
	      (res '()))
     (if (eq? num 0)
	 (if (<= num 2)
	     (reverse res)
	     (let* ((res0 (reverse res))
		    (first-glue (car res0))
		    (rem-glues (cdr res0)))
	       (cons first-glue
		     (reverse rem-glues))))
	 (let ((len (quotient remaining num)))
	   (loop (sub1 num)
		 (- remaining len)
		 (cons len res))))))

 ;; Expands given SGR line to width by expanding spaces
 (define (sgr-line-expand sl width)
   (let* ((sll (sgr-list-length-w/o-glues sl))
	  (rem0 (- width sll)))
     (if (>= rem0 0)
	 (let ((num-glues (sgr-list-num-glues sl)))
	   (if (> num-glues 0)
	       (let loop ((gluelens (compute-glue-lens
				     num-glues
				     rem0))
			  (sl sl)
			  (res '()))
		 (if (null? sl)
		     (reverse res)
		     (let ((tk (car sl)))
		       (if (sgr-token-glue? tk)
			   (loop (cdr gluelens)
				 (cdr sl)
				 (cons (cons (make-utf8-string (car gluelens) #\xA0)
					     (car gluelens))
				       res))
			   (loop gluelens
				 (cdr sl)
				 (cons (car sl) res))))))
	       ;; Nothing to expand, fill-in remainder with spaces
	       (reverse	(cons (cons (make-utf8-string rem0 #\xA0) rem0)
			      (reverse sl)))))
	 ;; Nowhere to expand
	 sl)))

 ;; Returns justification type: left, right, center, justify
 (define (analyze-sgr-line sl)
   (if (null? sl)
       'left
       (let* ((tk0 (if (sgr-state? (car sl))
		       (if (null? (cdr sl))
			   #f
			   (cadr sl))
		       (car sl)))
	      (rsl (reverse sl))
	      (tkl (if (sgr-state? (car rsl))
		       (if (null? (cdr rsl))
			   #f
			   (cadr rsl))
		       (car rsl))))
	 (if (not tk0)
	     'left
	     (if (sgr-token-glue? tk0)
		 (if (sgr-token-glue? tkl)
		     'center
		     'right)
		 (if (sgr-token-unglue? tkl)
		     'justify
		     'left))))))

 ;; Extracts initial state
 (define (sgr-line-extract-initial-state sl initial-state)
   (if (null? sl)
       (values sl initial-state)
       (if (sgr-state? (car sl))
	   (values (cdr sl) (car sl))
	   (if (and (not (null? (cdr sl)))
		    (sgr-state? (cadr sl)))
	       (values (cons (car sl)
			     (cddr sl))
		       (cadr sl))
	       (values sl initial-state)))))

 ;; Finishes line handling right glue properly
 (define (sgr-line-finish sl rightglue?)
   (if (null? sl)
       (if rightglue?
	   (list (cons "\t" 1))
	   '())
       (if rightglue?
	   (if (sgr-token-spaces? (car sl))
	       (reverse (cons (cons "\t" 1)
			      (cdr sl)))
	       (reverse (cons (cons "\t" 1)
			      sl)))
	   (if (sgr-token-spaces? (car sl))
	       (reverse (cdr sl))
	       (reverse sl)))))

 ;; Returns a list of wrapped sgr-lines and final state
 (define (sgr-line-wrap sl-arg width height initial-state-arg leftglue? rightglue? justify?)
   (let-values (((sl initial-state) (sgr-line-extract-initial-state sl-arg initial-state-arg)))
     (let loop ((sl sl)
		(line (if leftglue?
			  (list (cons "\t" 1) initial-state)
			  (list initial-state)))
		(content? #f)
		(llen 0)
		(res '())
		(rheight 1)
		(state initial-state))
       (if (or (null? sl)
	       (and height
		    (> rheight height)))
	   (values (if content?
		       (reverse (cons (sgr-line-finish line rightglue?)
				      res))
		       (reverse res))
		   state)
	   (let ((tk (car sl)))
	     (if (sgr-state? tk)
		 ;; State change, add and keep
		 (loop (cdr sl)
		       (cons tk line)
		       content?
		       llen
		       res
		       rheight
		       tk)
		 (let ((tklen (cdr tk)))
		   ;; Spaces, texts
		   (if (sgr-token-spaces? tk)
		       ;; Append only after content
		       (if (> (+ llen tklen) width)
			   ;; Spaces force line wrap
			   (loop (cdr sl)
				 (if leftglue?
				     (list (cons "\t" 1) state)
				     (list state))
				 #f
				 0
				 (cons (sgr-line-finish line rightglue?)
				       res)
				 (add1 rheight)
				 state)
			   ;; Spaces continue on the same line
			   (loop (cdr sl)
				 (if content?
				     (cons tk line)
				     line)
				 content?
				 (if content?
				     (+ llen tklen)
				     llen)
				 res
				 rheight
				 state))
		       (if (> (+ llen tklen) width)
			   ;; Wrap word
			   (loop (cdr sl)
				 (if leftglue?
				     (list tk (cons "\t" 1) state)
				     (list tk state))
				 #t
				 tklen
				 (cons (sgr-line-finish line rightglue?)
				       res)
				 (add1 rheight)
				 state)
			   ;; Keep on going
			   (loop (cdr sl)
				 (cons tk line)
				 #t
				 (+ llen tklen)
				 res
				 rheight
				 state))))))))))

 ;; Neutralizes line like sgr-list-neutralize, but returns final state
 ;; as well
 (define (sgr-line-neutralize sl initial-state)
   (let loop ((sl sl)
	      (res '())
	      (state initial-state))
     (if (null? sl)
	 (values (reverse res)
		 state)
	 (let ((tk (car sl)))
	   (loop (cdr sl)
		 (cons (sgr-token-neutralize tk) res)
		 (if (sgr-state? tk)
		     tk
		     state))))))

 ;; Renders single SGR line as block. If width is unspecified, only
 ;; glues are removed. If height is unspecified, the block can have
 ;; any height. With width the line is rendered and glues are expanded
 ;; accordingly. With #:justify all spaces are glues and first and
 ;; last are removed before rendering. If there are no glues, the
 ;; width is set and the result is shorter than the specified width,
 ;; the line is simply right-padded with #\space.
 (define* (sgr-line-render sl
			   #:width (width #f)
			   #:height (height #f)
			   #:initial-state (initial-state empty-sgr-state))
   (if width
       (let* ((alignment (analyze-sgr-line sl))
	      (sl (sgr-line-preprocess sl (eq? alignment 'justify))))
	 (let-values (((slw state)
		       (sgr-line-wrap sl
				      width height
				      initial-state
				      (memq alignment '(right center))
				      (memq alignment '(left center))
				      (eq? alignment 'justify))))
	   (values (map (lambda (sl)
			  (let ((sle (sgr-line-expand sl width)))
			    sle))
			(if (null? slw)
			    (list '())
			    slw))
		   state)))
       (let ((sln (sgr-list-neutralize sl)))
	 ;;(write sln)(newline)
	 (values (list sln) initial-state))))

 ;; Renders all the lines and appends the resulting blocks
 (define* (sgr-block-render sb
			    #:width (width (sgr-block-width sb))
			    #:height (height #f)
			    #:initial-state (initial-state empty-sgr-state))
   (let loop ((sb sb)
	      (res '())
	      (total-height 0)
	      (state initial-state))
     (if (or (null? sb)
	     (and height
		  (> total-height height)))
	 (let ((res (if (and height
			     (< total-height height))
			(let floop ((res0 '())
				    (idx (if height
					     (- height total-height)
					     0)))
			  (if (= idx 0)
			      (cons res0 res)
			      (floop (cons (sgr-line-expand (list state (cons "\t" 1))
							    width)
					   res0)
				     (sub1 idx))))
			res)))
	   (apply append (reverse res)))
	 (let ((sl (car sb)))
	   (let-values (((slb final-state)
			 (sgr-line-render sl
					  #:width width
					  #:height (if height
						       (- height total-height)
						       height)
					  #:initial-state state)))
	     (loop (cdr sb)
		   (cons slb
			 res)
		   (+ total-height
		      (sgr-block-height slb))
		   final-state
		   ))))))

 ;; Expands to given height
 (define (sgr-block-vexpand sb h)
   (let ((sbh (sgr-block-height sb)))
     (if (>= sbh h)
	 sb
	 (let* ((rsb (reverse sb))
		(sbw (if (null? sb)
			 0
			 (sgr-list-length (car sb))))
		(state (if (null? sb)
			   0
			   (sgr-list-last-state (car rsb))))
		(filler (list state
			      (cons (make-utf8-string sbw #\xA0)
				    sbw))))
	   (let loop ((rsb rsb)
		      (rh (- h sbh)))
	     (if (= 0 rh)
		 (reverse rsb)
		 (loop (cons filler rsb)
		       (sub1 rh))))))))

 ;; Appends blocks horizontally
 (define (sgr-block-happend b0 . rest)
   (if (null? rest)
       b0
       (let loop ((b0 b0)
		  (b1 (car rest))
		  (rres '()))
	 (if (null? b0)
	     (apply sgr-block-happend
		    (reverse rres)
		    (cdr rest))
	     (loop (cdr b0)
		   (cdr b1)
		   (cons (append (car b0)
				 (car b1))
			 rres))))))

 ;; Module self-tests
 (define (sgr-block-tests!)
   (run-tests
    sgr-block
    (test-equal? sgr-list->sgr-block
		 (sgr-list->sgr-block '(("Hello" . 5)))
		 '((("Hello" . 5))))
    (test-equal? sgr-list->sgr-block
		 (sgr-list->sgr-block '(("Hello" . 5)
					("\n" . 1)
					("World" . 5)))
		 '((("Hello" . 5))
		   (0 ("World" . 5))))
    (test-equal? sgr-list->sgr-block
		 (sgr-list->sgr-block '(1
					("Hello" . 5)
					("\n" . 1)
					0
					("World" . 5)))
		 '((1 ("Hello" . 5))
		   (0 ("World" . 5))))
    (test-equal? sgr-block->string-list
		 (sgr-block->string-list '((("Hello" . 5))
					   (1 ("World" . 5))))
		 '("Hello"
		   "\x1b[1mWorld"))
    (test-equal? sgr-block-width
		 (sgr-block-width '((("Hello" . 5))
				    (("Scheme" . 6)
				     (" " . 1)
				     ("World!" . 6))))
		 13)
    (test-equal? sgr-line-preprocess
		 (sgr-line-preprocess '(("Hello" . 5)
					 1
					 ("   " . 3)
					 0
					 ("World" . 5))
				      #t)
		 '(("Hello" . 5)
		   1
		   ("\t" . 1)
		   0
		   ("World" . 5)))
    (test-equal? sgr-line-preprocess
		 (sgr-line-preprocess '(("  " . 2)
					 ("Hello" . 5)
					 1
					 ("   " . 3)
					 0
					 ("World" . 5)
					 ("  " . 2))
				      #t)
		 '(("Hello" . 5)
		   1
		   ("\t" . 1)
		   0
		   ("World" . 5)))
    (test-equal? compute-glue-lens
		 (compute-glue-lens 1 10)
		 '(10))
    (test-equal? compute-glue-lens
		 (compute-glue-lens 2 10)
		 '(5 5))
    (test-equal? compute-glue-lens
		 (compute-glue-lens 2 11)
		 '(5 6))
    (test-equal? compute-glue-lens
		 (compute-glue-lens 3 11)
		 '(3 4 4))
    (test-equal? compute-glue-lens
		 (compute-glue-lens 3 14)
		 '(4 5 5))
    (test-equal? sgr-line-expand
		 (sgr-line-expand
		  '(("Hello" . 5) ("\t" . 1) ("World!" . 6))
		  20)
		 '(("Hello" . 5)
		   ("\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0" . 9)
		   ("World!" . 6)))
    ))

 )