49 lines
1.4 KiB
Scheme
49 lines
1.4 KiB
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; Message box dialog demo
|
|
|
|
(require 'motif)
|
|
(load 'radio-stuff.scm)
|
|
|
|
(define top (application-initialize 'message-box))
|
|
|
|
(define rc (create-managed-widget (find-class 'row-column) top))
|
|
|
|
(define box (create-radio-box 'push-button rc))
|
|
|
|
(define buttons
|
|
(map (lambda (label)
|
|
(radio-box-add-button! box 'label-string label
|
|
'alignment "alignment_center"))
|
|
'(error information message question warning working)))
|
|
|
|
(for-each
|
|
(lambda (button)
|
|
(add-callback button 'activate-callback
|
|
(lambda _
|
|
(post-dialog (car (get-values button 'label-string))))))
|
|
buttons)
|
|
|
|
(define box2 (create-radio-box 'toggle-button rc 'radio-behavior #f))
|
|
|
|
(define ok (radio-box-add-button! box2 'label-string 'OK-button 'set #t))
|
|
(define cancel (radio-box-add-button! box2 'label-string 'Cancel-button
|
|
'set #t))
|
|
(define help (radio-box-add-button! box2 'label-string 'Help-button 'set #t))
|
|
|
|
(define (post-dialog type)
|
|
(let* ((shell (create-popup-shell (find-class 'dialog-shell) rc))
|
|
(box (create-widget
|
|
(find-class 'message-box) shell
|
|
'dialog-type (string->symbol (string-append "dialog-" type)))))
|
|
(unless (car (get-values ok 'set))
|
|
(unmanage-child (name->widget box 'OK)))
|
|
(unless (car (get-values cancel 'set))
|
|
(unmanage-child (name->widget box 'Cancel)))
|
|
(unless (car (get-values help 'set))
|
|
(unmanage-child (name->widget box 'Help)))
|
|
(manage-child box)))
|
|
|
|
(realize-widget top)
|
|
(context-main-loop (widget-context top))
|