;; $Id: //info.ravenbrook.com/user/ndl/lisp/bcs/progress.lisp#1 $

(in-package "CL-USER")

;;                          PROGRESS.LISP
;;                     Nick Levine, 2006-04-09

;; The purpose of this document is to demonstrate the power of lisp
;; macros and closures by using them to implement a fully functional
;; interface for managing progress-bars.
;;
;; The macro with-progress-bar executes its body with a progress-bar
;; on display. The variable named by funvar is bound to a function
;; (actually, a closure). Call this function with a value in [0,1] to
;; reset the slug. If the function returns :destroyed, the
;; progress-bar has been closed.
;;
;; This document is provided "as is", without any express or implied
;; warranty.  In no event will the author be held liable for any
;; damages arising from the use of this document.  You may make and
;; distribute verbatim copies of this document provided that you do
;; not charge a fee for this document or for its distribution.

(defmacro with-progress-bar ((funvar title) &body body)
  (let ((progress-var (gensym "PROGRESS")))
    `(let* ((,progress-var (make-and-display-progress-bar ,title))
            (,funvar (lambda (value)
                       (when (window-still-alive ,progress-var)
                         ;; We might take the trouble to check that value is
                         ;; a number, in range, etc. What might we do if the
                         ;; check fails?
                         (setf (progress-bar-value ,progress-var) value)))))
       (unwind-protect
           (progn
             ,@body)
         (destroy-window ,progress-var)))))

;;;;;;;;;;;;;;;;;; Example of use ;;;;;;;;;;;;;;;;;;

(defun test-progress-bar ()
  (with-progress-bar (progress "Testing with-progress-bar")
    (dotimes (i 50)
      (sleep 0.1)
      (unless (funcall progress (/ i 50))
        (return i)))))

;;;;;;;;;;;; Implementation dependencies ;;;;;;;;;;;;

(defun make-and-display-progress-bar (title)
  (capi:contain (make-instance 'capi:progress-bar :end 1
                               :external-min-width 600
                               :external-max-width 600)
                :title title
                :x '(/ (- :screen-width 600) 2)
                :y '(/ (- :screen-height 200) 2)))

(defun window-still-alive (window)
  (when (capi:top-level-interface-display-state (capi:element-interface window))
    t))

(defun (setf progress-bar-value) (new-value progress-bar)
  (setf (capi:range-slug-start progress-bar) new-value))

(defun destroy-window (window)
  (let ((interface (capi:element-interface window)))
    (capi:execute-with-interface interface
                                 (lambda () (capi:destroy interface)))))