changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/cli/progress.lisp

changeset 698: 96958d3eb5b0
parent: 7ce855f76e1d
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; lib/cli/progress.lisp --- Progress Bars
     2 
     3 ;; from https://github.com/sirherrbatka/cl-progress-bar
     4 
     5 ;;; Code:
     6 (in-package :cli/progress)
     7 
     8 (defclass progress-bar ()
     9   ((start-time
    10     :initarg :start-time
    11     :accessor start-time)
    12    (end-time
    13     :initarg :end-time
    14     :accessor end-time)
    15    (progress-character
    16     :initarg :progress-character
    17     :accessor progress-character)
    18    (character-count
    19     :initarg :character-count
    20     :accessor character-count
    21     :documentation "How many characters wide is the progress bar?")
    22    (characters-so-far
    23     :initarg :characters-so-far
    24     :accessor characters-so-far)
    25    (update-interval
    26     :initarg :update-interval
    27     :accessor update-interval
    28     :documentation "Update the progress bar display after this many
    29     internal-time units.")
    30    (last-update-time
    31     :initarg :last-update-time
    32     :accessor last-update-time
    33     :documentation "The display was last updated at this time.")
    34    (total
    35     :initarg :total
    36     :accessor total
    37     :documentation "The total number of units tracked by this progress bar.")
    38    (progress
    39     :initarg :progress
    40     :accessor progress
    41     :documentation "How far in the progress are we?")
    42    (mutex
    43     :initarg :mutex
    44     :reader progress-mutex
    45     :documentation "Just a mutex, allows progress bar to be thread safe.")
    46    (pending
    47     :initarg :pending
    48     :accessor pending
    49     :documentation "How many raw units should be tracked in the next
    50     display update?"))
    51   (:default-initargs
    52    :mutex (sb-thread:make-mutex)
    53    :progress-character #\=
    54    :character-count 50
    55    :characters-so-far 0
    56    :update-interval (floor internal-time-units-per-second 4)
    57    :last-update-time 0
    58    :total 0
    59    :progress 0
    60    :pending 0))
    61 
    62 (defgeneric start-progress-display (progress-bar))
    63 (defgeneric update-progress (progress-bar unit-count))
    64 (defgeneric update-progress-display (progress-bar))
    65 (defgeneric finish-progress-display (progress-bar))
    66 (defgeneric elapsed-time (progress-bar))
    67 (defgeneric units-per-second (progress-bar))
    68 
    69 (defmethod start-progress-display (progress-bar)
    70   (setf (last-update-time progress-bar) (get-internal-real-time))
    71   (setf (start-time progress-bar) (get-internal-real-time))
    72   (fresh-line)
    73   (finish-output))
    74 
    75 (defmethod update-progress-display (progress-bar)
    76   (incf (progress progress-bar) (pending progress-bar))
    77   (setf (pending progress-bar) 0)
    78   (setf (last-update-time progress-bar) (get-internal-real-time))
    79   (unless (zerop (progress progress-bar))
    80     (let* ((showable (floor (character-count progress-bar)
    81                             (/ (total progress-bar) (progress progress-bar))))
    82            (needed (- showable (characters-so-far progress-bar))))
    83       (setf (characters-so-far progress-bar) showable)
    84       (dotimes (i needed)
    85         (write-char (progress-character progress-bar)))
    86       (finish-output))))
    87 
    88 (defmethod update-progress (progress-bar unit-count)
    89   (incf (pending progress-bar) unit-count)
    90   (let ((now (get-internal-real-time)))
    91     (when (< (update-interval progress-bar)
    92              (- now (last-update-time progress-bar)))
    93       (update-progress-display progress-bar))))
    94 
    95 (defconstant +seconds-in-one-hour+ 3600)
    96 (defconstant +seconds-in-one-minute+ 60)
    97 
    98 (defun time-in-seconds-minutes-hours (in-seconds)
    99   (unless (zerop in-seconds)
   100     (format t "Finished in")
   101     (when (>= in-seconds +seconds-in-one-hour+)
   102       (let* ((hours (floor (/ in-seconds +seconds-in-one-hour+))))
   103         (decf in-seconds (* hours +seconds-in-one-hour+))
   104         (format t " ~a hour~p" hours hours)))
   105     (when (>= in-seconds +seconds-in-one-minute+)
   106       (let* ((minutes (floor (/ in-seconds +seconds-in-one-minute+))))
   107         (decf in-seconds (* minutes +seconds-in-one-minute+))
   108         (format t " ~a minute~p" minutes minutes)))
   109     (unless (zerop in-seconds) (format t " ~$ seconds" in-seconds)))
   110   (terpri))
   111 
   112 (defmethod finish-progress-display (progress-bar)
   113   (update-progress-display progress-bar)
   114   (setf (end-time progress-bar) (get-internal-real-time))
   115   (terpri)
   116   (time-in-seconds-minutes-hours (elapsed-time progress-bar))
   117   (finish-output)
   118   (unless (= (progress progress-bar) (total progress-bar))
   119     (warn "Expected TOTAL is ~a but progress at the moment of finishing is ~a"
   120           (total progress-bar)
   121           (progress progress-bar))))
   122 
   123 (defmethod elapsed-time (progress-bar)
   124   (/ (- (end-time progress-bar) (start-time progress-bar))
   125      internal-time-units-per-second))
   126 
   127 (defmethod units-per-second (progress-bar)
   128   (if (plusp (elapsed-time progress-bar))
   129       (/ (total progress-bar) (elapsed-time progress-bar))
   130       0))
   131 
   132 (defparameter *uncertain-progress-chars* "?")
   133 
   134 (defclass uncertain-size-progress-bar (progress-bar)
   135   ((progress-char-index
   136     :initarg :progress-char-index
   137     :accessor progress-char-index)
   138    (units-per-char
   139     :initarg :units-per-char
   140     :accessor units-per-char))
   141   (:default-initargs
   142    :total 0
   143    :progress-char-index 0
   144    :units-per-char (floor (expt 1024 2) 50)))
   145 
   146 (defmethod update-progress :after ((progress-bar uncertain-size-progress-bar)
   147                                    unit-count)
   148   (incf (total progress-bar) unit-count))
   149 
   150 (defmethod progress-character ((progress-bar uncertain-size-progress-bar))
   151   (let ((index (progress-char-index progress-bar)))
   152     (prog1
   153         (char *uncertain-progress-chars* index)
   154       (setf (progress-char-index progress-bar)
   155             (mod (1+ index) (length *uncertain-progress-chars*))))))
   156 
   157 (defmethod update-progress-display ((progress-bar uncertain-size-progress-bar))
   158   (setf (last-update-time progress-bar) (get-internal-real-time))
   159   (multiple-value-bind (chars pend)
   160       (floor (pending progress-bar) (units-per-char progress-bar))
   161     (setf (pending progress-bar) pend)
   162     (dotimes (i chars)
   163       (write-char (progress-character progress-bar))
   164       (incf (characters-so-far progress-bar))
   165       (when (<= (character-count progress-bar)
   166                 (characters-so-far progress-bar))
   167         (terpri)
   168         (setf (characters-so-far progress-bar) 0)
   169         (finish-output)))
   170     (finish-output)))
   171 
   172 (defvar *progress-bar* nil)
   173 (defparameter *progress-bar-enabled* nil)
   174 
   175 (declaim (inline update))
   176 (defun update (unit-count &optional (progress-bar *progress-bar*))
   177   (check-type unit-count (integer 1 *))
   178   (check-type progress-bar (or null progress-bar))
   179   (unless (null progress-bar)
   180     (sb-thread:with-mutex ((progress-mutex progress-bar))
   181       (update-progress progress-bar unit-count))))
   182 
   183 (defun make-progress-bar (total)
   184   (check-type total (or null (integer 0 *)))
   185   (if (or (not total) (zerop total))
   186       (make-instance 'uncertain-size-progress-bar)
   187       (make-instance 'progress-bar
   188                      :total total)))
   189 
   190 (defmacro with-progress-bar ((steps-count description &rest desc-args) &body body)
   191   (let ((!old-bar (gensym)))
   192     `(let* ((,!old-bar *progress-bar*)
   193             (*progress-bar* (or ,!old-bar
   194                                 (when *progress-bar-enabled*
   195                                   (make-progress-bar ,steps-count)))))
   196        (unless (eq ,!old-bar *progress-bar*)
   197          (fresh-line)
   198          (format t ,description ,@desc-args)
   199          (start-progress-display *progress-bar*))
   200        (prog1 (progn ,@body)
   201          (unless (eq ,!old-bar *progress-bar*)
   202            (finish-progress-display *progress-bar*))))))
   203 
   204 (defmacro with-progress-maybe (enabled (steps-count description &rest desc-args) &body body)
   205   (declare (ignorable steps-count description desc-args))
   206   (if enabled
   207       `(with-progress-bar (,steps-count ,description ,@desc-args) ,@body)
   208       `(progn ,@body)))