gtk/gtk.high-level.lisp

   1 (in-package :gtk)
   2
   3 (defun call-within-main-loop-and-wait (fn)
   4   (let ((lock (bt:make-lock))
   5         (cv (bt:make-condition-variable))
   6         result)
   7     (bt:with-lock-held (lock)
   8       (within-main-loop
   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))))
  14
  15 (export 'call-within-main-loop-and-wait)
  16
  17 (defmacro within-main-loop-and-wait (&body body)
  18   `(call-within-main-loop-and-wait (lambda () ,@body)))
  19
  20 (export 'within-main-loop-and-wait)
  21
  22 (defstruct progress-display parent name count bar time-started current)
  23
  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)
  31
  32 (defstruct (progress-window (:include progress-display)) window box)
  33
  34 (export 'progress-window)
  35 (export 'progress-window-window)
  36 (export 'progress-window-box)
  37
  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)
  45       (widget-show window)
  46       (make-progress-window :parent nil :name name :count count :bar bar :window window :box box :time-started (get-internal-real-time) :current 0))))
  47
  48 (defun progress-display-root (progress)
  49   (if (progress-display-parent progress)
  50       (progress-display-root (progress-display-parent progress))
  51       progress))
  52
  53 (defun create-progress-bar (parent name count)
  54   (assert name) (assert count)
  55   (if parent
  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)
  60           (widget-show bar)
  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)))
  63
  64 (export 'create-progress-window)
  65
  66 (defgeneric delete-progress-bar (bar))
  67
  68 (export 'delete-progress-bar)
  69
  70 (defmethod delete-progress-bar ((bar progress-window))
  71   (within-main-loop-and-wait (object-destroy (progress-window-window bar))))
  72
  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)))))
  76
  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         (milliseconds (truncate (mod (* seconds 1000) 1000))))
  83     (format stream "~2,'0D:~2,'0D:~2,'0D.~3,'0D" hours minutes seconds milliseconds)))
  84
  85 (defun update-progress-bar-text (bar &optional (lower-frac 0.0))
  86   (let* ((elapsed (coerce (/ (- (get-internal-real-time)
  87                                 (progress-display-time-started bar))
  88                              internal-time-units-per-second)
  89                           'double-float))
  90          (process-rate (coerce (/ elapsed (+ lower-frac (progress-display-current bar))) 'double-float))
  91          (total-time (coerce (* (progress-display-count bar) process-rate) 'double-float)))
  92     (setf (progress-bar-text (progress-display-bar bar))
  93           (format nil "~A (~/gtk::format-duration/; ETA ~/gtk::format-duration/)" (progress-display-name bar) elapsed total-time))))
  94
  95 (defun update-progress-bar-texts (bar &optional (lower-frac 0.0))
  96   (when bar
  97     (update-progress-bar-text bar lower-frac)
  98     (update-progress-bar-texts (progress-display-parent bar) (coerce (/ (progress-display-current bar) (progress-display-count bar)) 'double-float))))
  99
 100 (defun tick-progress-bar (bar)
 101   (when bar
 102     (within-main-loop-and-wait
 103       (incf (progress-bar-fraction (progress-display-bar bar))
 104             (coerce (/ (progress-display-count bar)) 'double-float))
 105       (incf (progress-display-current bar))
 106       (update-progress-bar-text bar))))
 107
 108 (export 'tick-progress-bar)
 109
 110 (defvar *current-progress-bar* nil)
 111
 112 (defmacro with-progress-bar ((name count) &body body)
 113   (let ((bar (gensym)))
 114     `(let* ((,bar (create-progress-bar *current-progress-bar* ,name ,count))
 115             (*current-progress-bar* ,bar))
 116        (unwind-protect
 117             (progn ,@body)
 118          (delete-progress-bar ,bar)))))
 119
 120 (export 'with-progress-bar)
 121
 122 (defmacro with-progress-bar-action (&body body)
 123   `(multiple-value-prog1 (progn ,@body)
 124      (tick-progress-bar *current-progress-bar*)))
 125
 126 (export 'with-progress-bar-action)
 127
 128 (defun test-progress ()
 129   (with-progress-bar ("Snowball" 10)
 130     (loop
 131        repeat 10
 132        do (with-progress-bar-action
 133             (with-progress-bar ("Texts" 10)
 134               (loop
 135                  repeat 10
 136                  do (with-progress-bar-action (sleep 1))))))))