Move sources to separate directory.

progress.scm

@@ -1,166 +0,0 @@
-;;
-;; 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
- (
-  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))
-
- ;; Parameterized current progress string
- (define *current-progress* (make-parameter #f))
-
- ;; Prints current progress.
- (define (print-current-progress . args)
-   (let ((cp (*current-progress*)))
-     (when cp
-       (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 echo?
-	 (print post-msg))
-       result)))
-
- ;; Allows printing output when progress is advancing.
- (define (run-progress-break thunk)
-   (when (*current-progress*)
-     (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%)
-   (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%*))))))
-
- ;; 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 (>= (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* 0)
-		  (*current-progress%-range* (cons 0 1)))
-     (print-current-progress%)
-     (let ((result (thunk)))
-       (print-current-progress%)
-       (when echo?
-	 (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)
-
- )