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 update-progress-bar-text (bar &optional (lower-frac 0.0))
  78   (let* ((elapsed (coerce (/ (- (get-internal-real-time)
  79                                 (progress-display-time-started bar))
  80                              internal-time-units-per-second)
  81                           'double-float))
  82          (process-rate (coerce (/ elapsed (+ lower-frac (progress-display-current bar))) 'double-float))
  83          (total-time (coerce (* (progress-display-count bar) process-rate) 'double-float)))
  84     (setf (progress-bar-text (progress-display-bar bar))
  85           (format nil "~A (~$ of ETA ~$)" (progress-display-name bar) elapsed total-time))))
  86
  87 (defun update-progress-bar-texts (bar &optional (lower-frac 0.0))
  88   (when bar
  89     (update-progress-bar-text bar lower-frac)
  90     (update-progress-bar-texts (progress-display-parent bar) (coerce (/ (progress-display-current bar) (progress-display-count bar)) 'double-float))))
  91
  92 (defun tick-progress-bar (bar)
  93   (when bar
  94     (within-main-loop-and-wait
  95       (incf (progress-bar-fraction (progress-display-bar bar))
  96             (coerce (/ (progress-display-count bar)) 'double-float))
  97       (incf (progress-display-current bar))
  98       (update-progress-bar-text bar))))
  99
 100 (export 'tick-progress-bar)
 101
 102 (defvar *current-progress-bar* nil)
 103
 104 (defmacro with-progress-bar ((name count) &body body)
 105   (let ((bar (gensym)))
 106     `(let* ((,bar (create-progress-bar *current-progress-bar* ,name ,count))
 107             (*current-progress-bar* ,bar))
 108        (unwind-protect
 109             (progn ,@body)
 110          (delete-progress-bar ,bar)))))
 111
 112 (export 'with-progress-bar)
 113
 114 (defmacro with-progress-bar-action (&body body)
 115   `(multiple-value-prog1 (progn ,@body)
 116      (tick-progress-bar *current-progress-bar*)))
 117
 118 (export 'with-progress-bar-action)
 119
 120 (defun test-progress ()
 121   (with-progress-bar ("Snowball" 4)
 122     (loop
 123        repeat 4
 124        do (with-progress-bar-action
 125             (with-progress-bar ("Texts" 10)
 126               (loop
 127                  repeat 10
 128                  do (with-progress-bar-action (sleep 1))))))))