data-objects/progress-bar.lisp at master · dbmcclain/data-objects · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
;; progress-bar.lisp -- a more general purpose progress bar with user cancel button
;;
;; DM/RAL 06/07
;; ----------------------------------------------------------------------------

(in-package #:progress-bar)

(capi:define-interface progress-bar-without-cancel ()
  ((modulo  :accessor progress-bar-modulo :initarg  :modulo   :initform   t)
   (bar-min :accessor progress-bar-min    :initarg  :bar-min  :initform   0)
   (bar-max :accessor progress-bar-max    :initarg  :bar-max  :initform 100))

  (:panes
   (progress-bar-pane
    capi:progress-bar
    :start bar-min
    :end   bar-max
    :slug-start 0
    :visible-min-width 300
    :visible-max-width 300
    :accessor progress-bar-pane))

  (:layouts
   (main-layout
    capi:column-layout
    '(progress-bar-pane)
    :adjust :right))

  (:default-initargs
   :layout  'main-layout
   :window-styles '(#|:borderless|#
                    :never-iconic
                    :textured-background ;; only works if :borderless is false
                    :moveable-by-window-background
                    :shadowed
                    :always-on-top)
   ;;:transparency 0.5
   ;;:title   "FSync Scanning..."
   :title "Please Wait..."
   :auto-menus nil
   :confirm-destroy-function (constantly nil)
   ))

(defmethod initialize-instance :after ((obj progress-bar-without-cancel) &key &allow-other-keys)
  obj)

(defmethod progress-bar-cancel ((intf progress-bar-without-cancel))
  nil)

;; -------------------------------------------------------------------------

(capi:define-interface progress-bar-with-cancel ()
  ((cancel  :accessor progress-bar-cancel :initform nil)
   (modulo  :accessor progress-bar-modulo :initarg  :modulo   :initform   t)
   (bar-min :accessor progress-bar-min    :initarg  :bar-min  :initform   0)
   (bar-max :accessor progress-bar-max    :initarg  :bar-max  :initform 100))

  (:panes
   (progress-bar-pane
    capi:progress-bar
    :start bar-min
    :end   bar-max
    :slug-start 0
    :visible-min-width 300
    :visible-max-width 300
    :accessor progress-bar-pane)
   (cancel-button
    capi:push-button
    :accessor      progress-bar-cancel-button
    :data          "Cancel"
    :callback      'kill-scan
    :callback-type :interface))

  (:layouts
   (main-layout
    capi:column-layout
    '(progress-bar-pane
      cancel-button)
    :adjust :right))

  (:default-initargs
   :layout  'main-layout
   :window-styles '(#|:borderless|#
                    :never-iconic
                    :textured-background ;; only works if :borderless is false
                    :moveable-by-window-background
                    :shadowed
                    :always-on-top)
   ;;:transparency 0.5
   ;;:title   "FSync Scanning..."
   :title "Please Wait..."
   :auto-menus nil
   :confirm-destroy-function (constantly nil)
   ))

(defmethod initialize-instance :after ((obj progress-bar-with-cancel) &key &allow-other-keys)
  obj)

(define-condition user-cancel (condition) ())

(defun kill-scan (intf)
  (setf (progress-bar-cancel intf) t))

(defun incr-value (intf &optional (dbar 1))
  ;; called only from within the capi pane process
  (if (progress-bar-cancel intf)
      (error 'user-cancel)
    (capi:execute-with-interface
     intf
     (lambda ()
       (let* ((bar    (progress-bar-pane intf))
              (new-ct (+ dbar (capi:range-slug-start bar)))
              (limit  (capi:range-end bar)))
         (when (>= new-ct limit)
           (setf new-ct
                 (if (progress-bar-modulo intf)
                     (mod new-ct limit)
                   limit)))
         (setf (capi:range-slug-start bar) new-ct))
       ))
    ))

(defun set-value (intf val)
  ;; called only from within the capi pane process
  (if (progress-bar-cancel intf)
      (error 'user-cancel)
    (let ((bar (progress-bar-pane intf)))
      (capi:execute-with-interface
       intf
       (lambda ()
         (setf (capi:range-slug-start bar) val))
       ))))

(defun do-with-progress-bar (fn initargs)
  (let ((bar (capi:display
              (apply 'make-instance
                     (if (getf initargs :allow-cancel)
                         'progress-bar-with-cancel
                       'progress-bar-without-cancel)
                     initargs))))
    (unwind-protect
        (funcall fn bar)
      (capi:execute-with-interface bar
                                   'capi:destroy bar)
      )))

(defmacro with-progress-bar ((bar-name &rest initargs) &body body)
  `(do-with-progress-bar (lambda (,bar-name)
                           ,@body)
                         (list ,@initargs)))

#+:LISPWORKS
(editor:setup-indent "with-progress-bar" 1)