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     (format stream "~2,'0D:~2,'0D:~2,'0D" hours minutes seconds)))
  83
  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)
  88                           'double-float))
  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))))
  93
  94 (defun update-progress-bar-texts (bar &optional (lower-frac 0.0))
  95   (when bar
  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))))
  98
  99 (defun tick-progress-bar (bar)
 100   (when 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))))
 106
 107 (export 'tick-progress-bar)
 108
 109 (defvar *current-progress-bar* nil)
 110
 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))
 115        (unwind-protect
 116             (progn ,@body)
 117          (delete-progress-bar ,bar)))))
 118
 119 (export 'with-progress-bar)
 120
 121 (defmacro with-progress-bar-action (&body body)
 122   `(multiple-value-prog1 (progn ,@body)
 123      (tick-progress-bar *current-progress-bar*)))
 124
 125 (export 'with-progress-bar-action)
 126
 127 (defun test-progress ()
 128   (with-progress-bar ("Snowball" 10)
 129     (loop
 130        repeat 10
 131        do (with-progress-bar-action
 132             (with-progress-bar ("Texts" 10)
 133               (loop
 134                  repeat 10
 135                  do (with-progress-bar-action (sleep 1))))))))
 136
 137 (defun show-message (message &key (buttons :ok) (message-type :info) (use-markup nil))
 138   (let ((dialog (make-instance 'message-dialog
 139                                :text message
 140                                :buttons buttons
 141                                :message-type message-type
 142                                :use-markup use-markup)))
 143     (prog1
 144         (dialog-run dialog)
 145       (object-destroy dialog))))
 146
 147 (export 'show-message)