gtk/gtk.high-level.lisp

   1 (in-package :gtk)
   2
   3 (define-condition gtk-call-aborted (error)
   4   ((condition :initarg :condition :reader gtk-call-aborted-condition))
   5   (:report (lambda (c stream)
   6              (format stream "Call within main loop aborted because of error:~%~A" (gtk-call-aborted-condition c)))))
   7
   8 (defun call-within-main-loop-and-wait (fn)
   9   (let ((lock (bt:make-lock))
  10         (cv (bt:make-condition-variable))
  11         error
  12         result)
  13     (bt:with-lock-held (lock)
  14       (within-main-loop
  15         (handler-case
  16             (setf result (multiple-value-list (funcall fn)))
  17           (error (e) (setf error e)))
  18         (bt:with-lock-held (lock)
  19           (bt:condition-notify cv)))
  20       (bt:condition-wait cv lock)
  21       (if error
  22           (error 'gtk-call-aborted :condition error)
  23           (values-list result)))))
  24
  25 (export 'call-within-main-loop-and-wait)
  26
  27 (defmacro within-main-loop-and-wait (&body body)
  28   `(call-within-main-loop-and-wait (lambda () ,@body)))
  29
  30 (export 'within-main-loop-and-wait)
  31
  32 (defstruct progress-display parent name count bar time-started current)
  33
  34 (export 'progress-display)
  35 (export 'progress-display-parent)
  36 (export 'progress-display-name)
  37 (export 'progress-display-count)
  38 (export 'progress-display-bar)
  39 (export 'progress-display-time-started)
  40 (export 'progress-display-current)
  41
  42 (defstruct (progress-window (:include progress-display)) window box)
  43
  44 (export 'progress-window)
  45 (export 'progress-window-window)
  46 (export 'progress-window-box)
  47
  48 (defun create-progress-window (name count)
  49   (within-main-loop-and-wait
  50     (let* ((window (make-instance 'gtk-window :type :toplevel :title name :window-position :center))
  51            (box (make-instance 'v-box))
  52            (bar (make-instance 'progress-bar :text name)))
  53       (container-add window box)
  54       (box-pack-start box bar :expand nil)
  55       (widget-show window)
  56       (make-progress-window :parent nil :name name :count count :bar bar :window window :box box :time-started (get-internal-real-time) :current 0))))
  57
  58 (defun progress-display-root (progress)
  59   (if (progress-display-parent progress)
  60       (progress-display-root (progress-display-parent progress))
  61       progress))
  62
  63 (defun create-progress-bar (parent name count)
  64   (assert name) (assert count)
  65   (if parent
  66       (within-main-loop-and-wait
  67         (let* ((root (progress-display-root parent))
  68                (bar (make-instance 'progress-bar :text name)))
  69           (box-pack-start (progress-window-box root) bar :expand nil)
  70           (widget-show bar)
  71           (make-progress-display :parent parent :name name :count count :bar bar :time-started (get-internal-real-time) :current 0)))
  72       (create-progress-window name count)))
  73
  74 (export 'create-progress-window)
  75
  76 (defgeneric delete-progress-bar (bar))
  77
  78 (export 'delete-progress-bar)
  79
  80 (defmethod delete-progress-bar ((bar progress-window))
  81   (within-main-loop-and-wait (object-destroy (progress-window-window bar))))
  82
  83 (defmethod delete-progress-bar ((bar progress-display))
  84   (let ((root (progress-display-root bar)))
  85     (within-main-loop-and-wait (container-remove (progress-window-box root) (progress-display-bar bar)))))
  86
  87 (defun format-duration (stream seconds colon-modifier-p at-sign-modifier-p)
  88   (declare (ignore colon-modifier-p at-sign-modifier-p))
  89   (let ((seconds (mod (truncate seconds) 60))
  90         (minutes (mod (truncate seconds 60) 60))
  91         (hours (truncate seconds 3600)))
  92     (format stream "~2,'0D:~2,'0D:~2,'0D" hours minutes seconds)))
  93
  94 (defun update-progress-bar-text (bar &optional (lower-frac 0.0))
  95   (let* ((elapsed (coerce (/ (- (get-internal-real-time)
  96                                 (progress-display-time-started bar))
  97                              internal-time-units-per-second)
  98                           'double-float))
  99          (process-rate (coerce (/ elapsed (+ lower-frac (progress-display-current bar))) 'double-float))
 100          (total-time (coerce (* (progress-display-count bar) process-rate) 'double-float)))
 101     (setf (progress-bar-text (progress-display-bar bar))
 102           (format nil "~A (~/gtk::format-duration/; ETA ~/gtk::format-duration/)" (progress-display-name bar) elapsed total-time))))
 103
 104 (defun update-progress-bar-texts (bar &optional (lower-frac 0.0))
 105   (when bar
 106     (update-progress-bar-text bar lower-frac)
 107     (update-progress-bar-texts (progress-display-parent bar) (coerce (/ (progress-display-current bar) (progress-display-count bar)) 'double-float))))
 108
 109 (defun tick-progress-bar (bar)
 110   (when bar
 111     (within-main-loop-and-wait
 112       (incf (progress-bar-fraction (progress-display-bar bar))
 113             (coerce (/ (progress-display-count bar)) 'double-float))
 114       (incf (progress-display-current bar))
 115       (update-progress-bar-text bar))))
 116
 117 (export 'tick-progress-bar)
 118
 119 (defvar *current-progress-bar* nil)
 120
 121 (defmacro with-progress-bar ((name count) &body body)
 122   (let ((bar (gensym)))
 123     `(let* ((,bar (create-progress-bar *current-progress-bar* ,name ,count))
 124             (*current-progress-bar* ,bar))
 125        (unwind-protect
 126             (progn ,@body)
 127          (delete-progress-bar ,bar)))))
 128
 129 (export 'with-progress-bar)
 130
 131 (defmacro with-progress-bar-action (&body body)
 132   `(multiple-value-prog1 (progn ,@body)
 133      (tick-progress-bar *current-progress-bar*)))
 134
 135 (export 'with-progress-bar-action)
 136
 137 (defun test-progress ()
 138   (with-progress-bar ("Snowball" 10)
 139     (loop
 140        repeat 10
 141        do (with-progress-bar-action
 142             (with-progress-bar ("Texts" 10)
 143               (loop
 144                  repeat 10
 145                  do (with-progress-bar-action (sleep 1))))))))
 146
 147 (defun show-message (message &key (buttons :ok) (message-type :info) (use-markup nil))
 148   (let ((dialog (make-instance 'message-dialog
 149                                :text message
 150                                :buttons buttons
 151                                :message-type message-type
 152                                :use-markup use-markup)))
 153     (prog1
 154         (dialog-run dialog)
 155       (object-destroy dialog))))
 156
 157 (export 'show-message)