;;
;; progress.scm
;;
;; Progress reporting.
;;
;; ISC License
;;
;; Copyright 2023 Brmlab, z.s.
;; 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 progress))

(module
 progress
 (
  *progress-quiet*
  
  run-with-progress
  progress-advance
  with-progress
  run-progress-break
  progress-break

  *progress%-width*
  *progress%-step*
  run-with-progress%
  with-progress%
  progress%-advance
  )

 (import scheme
	 (chicken base)
	 (chicken format)
	 (chicken port)
	 util-time)

 ;; Suppress all output if #t
 (define *progress-quiet* (make-parameter #f))

 ;; Parameterized current progress string
 (define *current-progress* (make-parameter #f))

 ;; Prints current progress.
 (define (print-current-progress . args)
   (let ((cp (*current-progress*)))
     (when (and cp
		(not (*progress-quiet*)))
       (display (sprintf "\r\x1b[K~A" cp)))))

 ;; Adds something to current progress and refreshes the display.
 (define (progress-advance . args)
   (when (*current-progress*)
     (let ((str (if (null? args)
		    "."
		    (car args))))
       (*current-progress* (string-append (*current-progress*) (sprintf "~A" str)))
       (print-current-progress))))

 ;; Runs given procedure within progress environment
 (define (run-with-progress echo? pre-msg post-msg thunk)
   (parameterize ((*current-progress* (if echo? pre-msg #f)))
     (print-current-progress)
     (let ((result (thunk)))
       (print-current-progress)
       (when (and echo?
		  (not (*progress-quiet*)))
	 (print post-msg))
       result)))

 ;; Allows printing output when progress is advancing.
 (define (run-progress-break thunk)
   (when (and (*current-progress*)
	      (not (*progress-quiet*)))
     (display "\r\x1b[K"))
   (thunk)
   (print-current-progress))

 ;; Friendly syntax wrapper.
 (define-syntax with-progress
   (syntax-rules ()
     ((_ echo? pre post body ...)
      (run-with-progress echo? pre post (lambda () body ...)))))

 ;; Evaluate some expressions without progress.
 (define-syntax progress-break
   (syntax-rules ()
     ((_ body ...)
      (run-progress-break (lambda () body ...)))))

 ;; Progress% visual configuration
 (define *progress%-width* (make-parameter 40))

 ;; Progress% time step configuration
 (define *progress%-step* (make-parameter 0.01))

 ;; Tracking the progress via set of parameters
 (define *current-progress%* (make-parameter #f))
 (define *current-progress%-echo?* (make-parameter #f))
 (define *current-progress%-value* (make-parameter #f))
 (define *current-progress%-last-value* (make-parameter #f))
 (define *current-progress%-range* (make-parameter (cons 0 1)))

 ;; Unconditionally prints the current progress.
 (define (print-current-progress% . eols)
   (when (not (*progress-quiet*))
     (let ((eol (if (null? eols)
		    ""
		    (car eols))))
       (when (and (*current-progress%*)
		  (*current-progress%-echo?*))
	 (let* ((raw-value (*current-progress%-value*))
		(range (*current-progress%-range*))
		(value (+ (car range)
			  (* raw-value
			     (- (cdr range) (car range)))))
		(value% (* 100 value))
		(ivalue% (inexact->exact (round value%)))
		(bwidth (inexact->exact
			 (round
			  (* value (*progress%-width*)))))
		(swidth (- (*progress%-width*) bwidth)))
	   (display
	    (sprintf "\r[~A~A] ~A% ~A~A"
		     (make-string bwidth #\=)
		     (make-string swidth #\space)
		     ivalue%
		     (*current-progress%*)
		     eol)))))))

 ;; If the new value is different-enough from the current one, updates
 ;; it and re-prints the progress%
 (define (progress%-advance new-value)
   (when (*current-progress%*)
     (*current-progress%-value* new-value)
     (let ((old-value (*current-progress%-last-value*)))
       (when (or (not old-value)
		 (>= (abs (- new-value old-value)) (*progress%-step*)))
	 (*current-progress%-last-value* new-value)
	 (print-current-progress%)))))

 ;; Procedure realizing the actual progress tracking
 (define (run-with-progress% echo? name thunk)
   (parameterize ((*current-progress%* name)
		  (*current-progress%-echo?* echo?)
		  (*current-progress%-value* 0)
		  (*current-progress%-last-value* #f)
		  (*current-progress%-range* (cons 0 1)))
     (let ((start (current-util-milliseconds)))
       (print-current-progress%)
       (let ((result (thunk))
	     (stop (current-util-milliseconds)))
	 (print-current-progress% (sprintf " ~A ms" (- stop start)))
	 (when (and echo?
		    (not (*progress-quiet*)))
	   (newline))
	 result))))

 ;; Runs named progress%
 (define-syntax with-progress%
   (syntax-rules ()
     ((_ echo? name body ...)
      (run-with-progress%
       echo? name
       (lambda () body ...)))))

 ;; If the program uses progress module, disable buffering
 (set-buffering-mode! (current-output-port) #:none)

 )