[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Modal dialogs like the Finder
- To: cartier@math.uqam.ca (Guillaume Cartier)
- Subject: Re: Modal dialogs like the Finder
- From: Luke Hohmann <hohmann@csmil.umich.edu>
- Date: Fri, 18 Oct 91 13:19:26 -0400
- Cc: info-mcl@cambridge.apple.com (Macintosh Common Lisp)
- In-reply-to: Your message of Fri, 18 Oct 91 12:57:18 -0400. <9110181657.AA11352@mipsmath>
Perhaps this code might be useful? MCL, v1.3.2....
(in-package :ccl)
(export '(*gray-box-dialog-item* *black-box-dialog-item*
*fill-box-dialog-item* set-status))
;; CLASS: *gray-box-dialog-item* =================================================
;;
;; SUPERCLASSES : *graphic-dialog-item*
;; DESCRIPTION :
;; SLOTS :
;; REVISION HISTORY
;; 04/16/91 bar - Initial version
;;
(defobject *gray-box-dialog-item* *graphic-dialog-item*)
;; METHOD: dialog-item-draw *gray-box-dialog-item* ----------------------------
;;
;; DESCRIPTION: Draws a gray box
;; NOTES:
;; PARAMETERS:
;; RETURNS:
;; CALLS:
;; REVISION HISTORY
;; 04/16/91 bar - Initial version
;;
(defobfun (dialog-item-draw *gray-box-dialog-item*) ()
(declare (object-variable my-dialog))
(let* ((topleft (dialog-item-position))
(bottomright (add-points topleft (objvar dialog-item-size-iv))))
(ask my-dialog
(set-pen-pattern *gray-pattern*)
(frame-rect topleft bottomright)
(set-pen-pattern *black-pattern*))))
;; CLASS: *black-box-dialog-item* =================================================
;;
;; SUPERCLASSES : *graphic-dialog-item*
;; DESCRIPTION :
;; SLOTS :
;; REVISION HISTORY
;; 04/16/91 bar - Initial version
;;
(defobject *black-box-dialog-item* *graphic-dialog-item*)
;; METHOD: dialog-item-draw *black-box-dialog-item* ----------------------------
;;
;; DESCRIPTION: Draws a black box
;; NOTES:
;; PARAMETERS:
;; RETURNS:
;; CALLS:
;; REVISION HISTORY
;; 04/16/91 bar - Initial version
;;
(defobfun (dialog-item-draw *black-box-dialog-item*) ()
(declare (object-variable my-dialog))
(let* ((topleft (dialog-item-position))
(bottomright (add-points topleft (objvar dialog-item-size-iv))))
(ask my-dialog
(set-pen-pattern *black-pattern*)
(frame-rect topleft bottomright)
(set-pen-pattern *black-pattern*))))
;; CLASS: *fill-box-dialog-item* =================================================
;;
;; SUPERCLASSES : *graphic-dialog-item*
;; DESCRIPTION :
;; SLOTS :
;; REVISION HISTORY
;; 04/16/91 bar - Initial version
;;
(defobject *fill-box-dialog-item* *graphic-dialog-item*)
(proclaim '(object-variable (*fill-box-dialog-item* min max current-value)))
;; METHOD: exist *fill-box-dialog-item* ----------------------------
;;
;; DESCRIPTION: Draws a fill box
;; NOTES:
;; PARAMETERS: total-size is a point?
;; RETURNS:
;; CALLS:
;; REVISION HISTORY
;; 04/16/91 bar - Initial version
;;
(defobfun (exist *fill-box-dialog-item*) (init-list)
(usual-exist init-list)
(have 'min (getf init-list :min 1))
(have 'max (getf init-list :max 100))
(have 'current-value (getf init-list :current-value 1)))
;; METHOD: dialog-item-draw *fill-box-dialog-item* ----------------------------
;;
;; DESCRIPTION: Draws a fill box
;; NOTES:
;; PARAMETERS:
;; RETURNS:
;; CALLS:
;; REVISION HISTORY
;; 04/16/91 bar - Initial version
;;
(defobfun (dialog-item-draw *fill-box-dialog-item*) ()
(declare (object-variable my-dialog))
(let* ((topleft (dialog-item-position))
(bottomright (add-points topleft (dialog-item-size)))
(inside-left (add-points topleft #@(1 1)))
(curr-value (add-points
(add-points inside-left
(make-point (floor (* (/ current-value max)
(point-h (dialog-item-size))))
(point-v (dialog-item-size))))
#@(-2 -2))))
(ask my-dialog
(set-pen-pattern *black-pattern*)
(frame-rect topleft bottomright)
(set-pen-pattern *dark-gray-pattern*)
(paint-rect inside-left curr-value)
(set-pen-pattern *black-pattern*)))
(values))
;; METHOD: set-status *fill-box-dialog-item* ----------------------------
;;
;; DESCRIPTION: Sets the completeness
;; NOTES:
;; PARAMETERS:
;; RETURNS:
;; CALLS:
;; REVISION HISTORY
;; 04/16/91 bar - Initial version
;;
(defobfun (set-status *fill-box-dialog-item*) (new-value)
(setf current-value new-value)
(dialog-item-draw)
(values))
;;=> *status-window* ---------------------------------------------------------
;;
;; DESCRIPTION:
;; a simple window to provide feedback to the user for time-consuming
;; processes.
;;
;;
;; IMPLEMENTATION NOTES:
;;
;; PARAMETERS:
;;
;; RETURNS:
;;
;; CALLS:
;;
;; REVISION HISTORY
;;
(defobject *status-window* *dialog*)
(defobfun (exist *status-window*) (init-list)
(let* ((the-title (getf init-list :title "Status"))
(min-value (getf init-list :min 0))
(max-value (getf init-list :max 50)))
(have 'min min-value)
(have 'max max-value)
(usual-exist
(init-list-default init-list
:window-title the-title
:close-box-p nil
:window-size #@(465 70)
:window-font '("Monaco" 9 :srccopy :bold)
:window-show nil
:dialog-items
(list
(oneof *fill-box-dialog-item*
:dialog-item-nick-name 'status-bar
:min min-value
:max max-value
:dialog-item-position #@(5 12)
:dialog-item-size #@(450 30))
(oneof *button-dialog-item*
:dialog-item-text "Cancel"
:dialog-item-size #@(93 16)
:dialog-item-position #@(362 48)
:dialog-item-nick-name 'cancel-button
:dialog-item-action
'(throw :status-break nil)))))))
(defobfun (update-status *status-window*) (new-value)
(declare (object-variable min max))
(when (and (>= new-value min)
(<= new-value max))
(ask-named-item 'status-bar (set-status new-value))))
(defobfun (draw-all-items *status-window*) ()
(ask-named-item 'status-bar (dialog-item-draw))
(ask-named-item 'cancel-button (dialog-item-draw)))
#|
-------------------------------------------------------------------------
------------------- TEST CODE -------------------------------------------
(setf biglist (list 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))
(defun test-status ()
(declare (special *eventhook*))
(let ((the-status-window (oneof *status-window*
:min 0
:max (length biglist)
:title "Biglist status"))
(old-eventhook nil))
(unwind-protect
(catch :status-break
(setf old-eventhook *eventhook*)
(ask the-status-window (window-select))
(setf *eventhook*
#'(lambda ()
(let* ((what (rref *current-event* event.what))
(where (rref *current-event* event.where))
(status-wptr (ask the-status-window wptr))
(the-safe-ptr nil))
(%stack-block ((which-window 4))
(setf where-clicked (_FindWindow :long where :ptr which-window :word))
(setf the-safe-wptr (%get-safe-ptr which-window))
;only interested in mouse-down events...
(when (or (eq what 1)
(eq what 3))
(not (eq the-safe-wptr status-wptr)))))))
(let ((total 0)
(count 0))
(mapcar #'(lambda (num)
(setf total (+ num total))
(format t "the total is ~a~%" total)
(ask the-status-window (update-status (incf count))))
biglist)))
(progn
(setf *eventhook* old-eventhook)
(ask the-status-window (window-close))))))
|#
-- Luke