brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Measure progress time.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-06 22:04:07 +02:00
parent 8bf4a882e3
commit 29631c640e
1 changed files with 33 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

59
src/progress.scm
View file

@ -44,7 +44,8 @@
(import scheme
(chicken base)
(chicken format)
(chicken port))
(chicken port)
(chicken time))
;; Parameterized current progress string
(define *current-progress* (make-parameter #f))
@ -107,26 +108,30 @@
(define *current-progress%-range* (make-parameter (cons 0 1)))
;; Unconditionally prints the current progress.
(define (print-current-progress%)
(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"
(make-string bwidth #\=)
(make-string swidth #\space)
ivalue%
(*current-progress%*))))))
(define (print-current-progress% . eols)
(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%
@ -146,12 +151,14 @@
(*current-progress%-value* 0)
(*current-progress%-last-value* #f)
(*current-progress%-range* (cons 0 1)))
(print-current-progress%)
(let ((result (thunk)))
(let ((start (current-milliseconds)))
(print-current-progress%)
(when echo?
(newline))
result)))
(let ((result (thunk))
(stop (current-milliseconds)))
(print-current-progress% (sprintf " ~A ms" (- stop start)))
(when echo?
(newline))
result))))
;; Runs named progress%
(define-syntax with-progress%