3 (defun call-within-main-loop-and-wait (fn)
4 (let ((lock (bt:make-lock))
5 (cv (bt:make-condition-variable))
7 (bt:with-lock-held (lock)
9 (setf result (multiple-value-list (funcall fn)))
10 (bt:with-lock-held (lock)
11 (bt:condition-notify cv)))
12 (bt:condition-wait cv lock)
13 (values-list result))))
15 (export 'call-within-main-loop-and-wait)
17 (defmacro within-main-loop-and-wait (&body body)
18 `(call-within-main-loop-and-wait (lambda () ,@body)))
20 (export 'within-main-loop-and-wait)
22 (defstruct progress-display parent name count bar time-started current)
24 (export 'progress-display)
25 (export 'progress-display-parent)
26 (export 'progress-display-name)
27 (export 'progress-display-count)
28 (export 'progress-display-bar)
29 (export 'progress-display-time-started)
30 (export 'progress-display-current)
32 (defstruct (progress-window (:include progress-display)) window box)
34 (export 'progress-window)
35 (export 'progress-window-window)
36 (export 'progress-window-box)
38 (defun create-progress-window (name count)
39 (within-main-loop-and-wait
40 (let* ((window (make-instance 'gtk-window :type :toplevel :title name :window-position :center))
41 (box (make-instance 'v-box))
42 (bar (make-instance 'progress-bar :text name)))
43 (container-add window box)
44 (box-pack-start box bar :expand nil)
46 (make-progress-window :parent nil :name name :count count :bar bar :window window :box box :time-started (get-internal-real-time) :current 0))))
48 (defun progress-display-root (progress)
49 (if (progress-display-parent progress)
50 (progress-display-root (progress-display-parent progress))
53 (defun create-progress-bar (parent name count)
54 (assert name) (assert count)
56 (within-main-loop-and-wait
57 (let* ((root (progress-display-root parent))
58 (bar (make-instance 'progress-bar :text name)))
59 (box-pack-start (progress-window-box root) bar :expand nil)
61 (make-progress-display :parent parent :name name :count count :bar bar :time-started (get-internal-real-time) :current 0)))
62 (create-progress-window name count)))
64 (export 'create-progress-window)
66 (defgeneric delete-progress-bar (bar))
68 (export 'delete-progress-bar)
70 (defmethod delete-progress-bar ((bar progress-window))
71 (within-main-loop-and-wait (object-destroy (progress-window-window bar))))
73 (defmethod delete-progress-bar ((bar progress-display))
74 (let ((root (progress-display-root bar)))
75 (within-main-loop-and-wait (container-remove (progress-window-box root) (progress-display-bar bar)))))
77 (defun format-duration (stream seconds colon-modifier-p at-sign-modifier-p)
78 (declare (ignore colon-modifier-p at-sign-modifier-p))
79 (let ((seconds (mod (truncate seconds) 60))
80 (minutes (mod (truncate seconds 60) 60))
81 (hours (truncate seconds 3600)))
82 (format stream "~2,'0D:~2,'0D:~2,'0D" hours minutes seconds)))
84 (defun update-progress-bar-text (bar &optional (lower-frac 0.0))
85 (let* ((elapsed (coerce (/ (- (get-internal-real-time)
86 (progress-display-time-started bar))
87 internal-time-units-per-second)
89 (process-rate (coerce (/ elapsed (+ lower-frac (progress-display-current bar))) 'double-float))
90 (total-time (coerce (* (progress-display-count bar) process-rate) 'double-float)))
91 (setf (progress-bar-text (progress-display-bar bar))
92 (format nil "~A (~/gtk::format-duration/; ETA ~/gtk::format-duration/)" (progress-display-name bar) elapsed total-time))))
94 (defun update-progress-bar-texts (bar &optional (lower-frac 0.0))
96 (update-progress-bar-text bar lower-frac)
97 (update-progress-bar-texts (progress-display-parent bar) (coerce (/ (progress-display-current bar) (progress-display-count bar)) 'double-float))))
99 (defun tick-progress-bar (bar)
101 (within-main-loop-and-wait
102 (incf (progress-bar-fraction (progress-display-bar bar))
103 (coerce (/ (progress-display-count bar)) 'double-float))
104 (incf (progress-display-current bar))
105 (update-progress-bar-text bar))))
107 (export 'tick-progress-bar)
109 (defvar *current-progress-bar* nil)
111 (defmacro with-progress-bar ((name count) &body body)
112 (let ((bar (gensym)))
113 `(let* ((,bar (create-progress-bar *current-progress-bar* ,name ,count))
114 (*current-progress-bar* ,bar))
117 (delete-progress-bar ,bar)))))
119 (export 'with-progress-bar)
121 (defmacro with-progress-bar-action (&body body)
122 `(multiple-value-prog1 (progn ,@body)
123 (tick-progress-bar *current-progress-bar*)))
125 (export 'with-progress-bar-action)
127 (defun test-progress ()
128 (with-progress-bar ("Snowball" 10)
131 do (with-progress-bar-action
132 (with-progress-bar ("Texts" 10)
135 do (with-progress-bar-action (sleep 1))))))))