;;;; progress-indicators.scm


(module progress-indicators (make-progress-bar
			     progress-bar?
			     progress-bar-value
			     show-progress-bar
			     finish-progress-bar!
			     advance-progress-bar!
			     make-spinner
			     spinner?
			     advance-spinner!
			     finish-spinner!)

(import scheme chicken)

(use defstruct extras srfi-13)

(defstruct progress-bar
  (fill #\=)
  (empty #\space)
  (head #\>)
  (frame "[~a~a~a~a|~a]")
  (value 0)
  (max 100)
  (width 60)
  (port (current-output-port))
  (end-message " complete")
  (last ""))

(define tty? 
  (let ((emacs (get-environment-variable "EMACS")))
    (lambda (port)
      (or emacs (##sys#tty-port? port)))))

(defstruct spinner
  (value 0)
  (once #f)
  (port (current-output-port))
  (steps "|/-\\"))

(define (advance-spinner! spn)
  (let* ((pic (spinner-steps spn))
	 (val (spinner-value spn))
	 (port (spinner-port spn)))
    (when (tty? port)
      (when (spinner-once spn)
	(write-char #\backspace port) )
      (write-char (string-ref pic val) port)
      (flush-output port))
    (spinner-value-set! spn (modulo (add1 val) (string-length pic)))
    (spinner-once-set! spn #t)))

(define (finish-spinner! spn)
  (let* ((val (spinner-value spn))
	 (port (spinner-port spn)))
    (when (and (tty? port) (spinner-once spn))
      (write-char #\backspace port)
      (flush-output port))
    (spinner-once-set! spn #f)))

(define (finish-progress-bar! pbar #!optional clr)
  (clear pbar)
  (unless clr
    (progress-bar-value-set! pbar (progress-bar-max pbar))
    (show pbar (progress-bar-end-message pbar) #t)
    (newline (progress-bar-port pbar)) ))

(define (advance-progress-bar! pbar #!optional (amount 1))
  (set! (progress-bar-value pbar) (+ amount (progress-bar-value pbar))))

(define progress-bar-value
  (getter-with-setter
   progress-bar-value
   (lambda (pbar val)
     (progress-bar-value-set! pbar val)
     (clear pbar)
     (show pbar) ) ) )

(define (clear pbar)
  (let ((port (progress-bar-port pbar)))
    (when (tty? port)
      (display 
       (make-string (string-length (progress-bar-last pbar)) #\backspace)
       port))))

(define (nice n)
  (cond ((> n 1000000000)
	 (sprintf "~ag" (inexact->exact (truncate (/ n 1000000000)))))
	((> n 1000000)
	 (sprintf "~am" (inexact->exact (truncate (/ n 1000000)))))
	((> n 1000)
	 (sprintf "~ak" (inexact->exact (truncate (/ n 1000)))))
	(else (number->string n))))

(define (show pbar #!optional msg end)
  (let* ((val (max 0 (progress-bar-value pbar)))
	 (maxval (progress-bar-max pbar))
	 (w (progress-bar-width pbar))
	 (n (sprintf " ~a%"
	      (string-pad
	       (number->string
		(inexact->exact 
		 (truncate (* (/ (min val maxval) maxval) 100))))
	       4)))
	 (vn (string-append (nice val) "/" (nice maxval)))
	 (vnl (string-length vn))
	 (port (progress-bar-port pbar))
	 (bar (inexact->exact (truncate (/ (min val maxval) (/ maxval w)))))
	 (show-n (fx> bar (fx+ vnl 1)))
	 (vn (if show-n vn ""))
	 (bar (if show-n (fx- bar vnl) bar))
	 (str (sprintf (progress-bar-frame pbar)
		vn
		(make-string bar (progress-bar-fill pbar))
		(if end
		    (progress-bar-fill pbar)
		    (progress-bar-head pbar))
		(make-string (- w bar (if show-n vnl 0)) #\space)
		(or msg n))))
    (progress-bar-last-set! pbar str)
    (display str port)
    (flush-output port)))

(define (show-progress-bar pbar)
  (clear pbar)
  (show pbar) )

)