Edgar Gonçalves - 2007-04-08

Logged In: YES
user_id=816366
Originator: NO

I created my most used dialogs for my personal use. Message box was based on your demo code; input-prompt asks for a textual value, and y-or-n-prompt, well, you can figure it out :). But the macro with-dialog is able to support most kinds of message dialogs you want, easily. Here's the code:

(defvar *parent* nil "current parent widget")

(defmacro make-label (title &key parent)
`(let ((*parent* ,(or parent '*parent*)))
(make-instance 'gfw:label :text ,title :parent *parent*)))

(defmacro make-textbox (&key title parent (columns 50) (lines 1) (enabled t))
(let ((initial-string (make-blank-string columns lines)))
`(let ((*parent* ,(or parent '*parent*)))
,(when title
`(make-label ,(concatenate 'string title ":") :parent *parent*))
(let ((new-textbox
(make-instance 'gfw:edit
:parent *parent*
:text ,initial-string
:style ,(and (> lines 1) ''(:multi-line :auto-hscroll :auto-vscroll :vertical-scrollbar :want-return)))))
(gfw:enable new-textbox ,enabled)
new-textbox))))

(defmacro make-button (&key parent callback (style ''(:default-button)) text)
`(make-instance 'gfw:button :parent ,(or parent '*parent*) :callback ,callback :style ,style :text ,text))

(defmacro with-panel ((var &key parent (dispatcher 'gfw:event-dispatcher) (layout 'gfw:flow-layout) (style '(:vertical)) (spacing 4) (margins 4)) &body body)
`(let* ((,var (make-instance 'gfw:panel
:dispatcher ,(if (symbolp dispatcher)
`(make-instance ',dispatcher)
dispatcher)
:parent ,(or parent '*parent*)
:layout (make-instance ',layout :style ',style :spacing ,spacing :margins ,margins)))
(*parent* ,var))
,@body))

(defclass dialog-events (gfw:event-dispatcher)
((return-value :accessor dialog-return-value :initarg return)))

(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog))
(call-next-method)
(gfs:dispose dlg))

(defclass value-dialog ()
((box :accessor value-dialog-box :initarg :box)
(msgs :accessor value-dialog-messages)
(input :accessor value-dialog-input)
(retbtn :accessor value-dialog-result
:initform 'ok)))

(defmethod show ((vdlg value-dialog))
(let ((dlg (value-dialog-box vdlg)))
(gfw:pack dlg)
(gfw:center-on-owner dlg)
(gfw:show dlg t)
(value-dialog-result vdlg)))

(defmacro with-dialog ((var &key owner (title "Dialog") (dispatcher 'dialog-events) image-path (layout 'gfw:flow-layout) (style ''(:owner-modal)) (spacing 8) (margins 8)) &body body)
(let ((label-var (gensym "label"))
(image-var (gensym "img")))
`(let* ((,var (make-instance 'gfw:dialog :owner ,owner
:dispatcher ,(if (symbolp dispatcher)
`(make-instance ',dispatcher)
dispatcher)
:layout (make-instance ',layout
:margins ,margins
:spacing ,spacing)
:style ,style
:text ,(or title `(gfw:text ,owner))))
(*parent* ,var))
(when ,image-path
(let ((,label-var (make-instance 'gfw:label :parent *parent*))
(,image-var (and ,image-path (make-instance 'gfg:image
:file ,(if (stringp image-path)
(merge-pathnames image-path
*project-directory*)
image-path)))))
(unwind-protect
(gfg:with-image-transparency (,image-var (gfs:make-point))
(setf (gfw:image ,label-var) ,image-var))
(gfs:dispose ,image-var))))
,@body)))

(defun y-or-n-prompt (owner desc &key image-path title yes no (yes-text "Yes") (no-text "No"))
(with-dialog (dlg :owner owner :title title :image-path image-path)
(let ((res (make-instance 'value-dialog :box dlg)))
(with-panel (text-panel :spacing 2 :margins 0)
(dolist (desc-line (if (listp desc) desc (list desc)))
(make-label desc-line)))
(with-panel (btn-panel :margins 0 :spacing 0 :style (:horizontal :normalize))
(make-button :text yes-text
:callback (lambda (disp btn)
(declare (ignore disp btn))
(setf (value-dialog-result res) (or yes t))
(gfs:dispose dlg)))
(make-button :text no-text
:callback (lambda (disp btn)
(declare (ignore disp btn))
(setf (value-dialog-result res) no)
(gfs:dispose dlg))))
(show res))))

(defun input-prompt (owner desc &key image-path title (btn-text "Ok"))
(with-dialog (dlg :owner owner :title title :image-path image-path)
(let ((res (make-instance 'value-dialog :box dlg))
text-box)
(with-panel (text-panel :spacing 2 :margins 0)
(dolist (desc-line (if (listp desc) desc (list desc)))
(make-label desc-line))
(setf text-box (make-textbox)))
(with-panel (btn-panel :margins 0 :spacing 0 :style (:horizontal :normalize))
(make-button :text btn-text
:callback (lambda (disp btn)
(declare (ignore disp btn))
(setf (value-dialog-result res) (gfw:text text-box))
(gfs:dispose dlg))))
(show res))))

(defun message-box (owner desc &key image-path title)
(with-dialog (dlg :owner owner :title title :image-path image-path)
(with-panel (text-panel :spacing 2 :margins 0)
(dolist (desc-line (if (listp desc) desc (list desc)))
(make-label desc-line)))
(with-panel (btn-panel :margins 0 :spacing 0 :style (:vertical :normalize))
(make-button :text "Ok"
:callback (lambda (disp btn)
(declare (ignore disp btn))
(gfs:dispose dlg))))
(show (make-instance 'value-dialog :box dlg))))