;;; -*-Scheme-*-
;;;
;;; (Stupid) dialog box demo

(require 'xwidgets)
(load-widgets shell dialog command box label)

(define con (create-context))
(define dpy (initialize-display con #f 'dialog 'demo))
(define top (create-shell 'dialog 'demo (find-class 'application-shell) dpy))

(define f (open-font dpy "*courier-bold-r-normal--14*"))
(define g (open-font dpy "*courier-bold-r-normal--18*"))

(define gray-bits "\10\2\10\2")
(define gray (create-bitmap-from-data (display-root-window dpy) gray-bits 4 4))

(define box (create-managed-widget (find-class 'box) top))
(set-values! box 'h-space 14 'v-space 14 'background-pixmap gray)

(define dialog (create-managed-widget (find-class 'dialog) box
        'value "/tmp/test" 'label "FILENAME:"))
(set-values! dialog 'width 80)
(set-values! (name->widget dialog 'label) 'font f)

(define button (create-managed-widget (find-class 'command) dialog))
(set-values! button 'label "cancel" 'font f)

(define button2 (create-managed-widget (find-class 'command) dialog))
(set-values! button2 'label "write" 'font f)
(add-callback button2 'callback
  (lambda (w)
    (format #t "Filename is ~s~%"
	    (car (get-values (widget-parent w) 'value)))))

(define bbox (create-managed-widget (find-class 'box) box))

(define l (create-managed-widget (find-class 'label) bbox 'border-width 0
	                         'font f 'label "TYPEFACE:"))
(define b1 (create-managed-widget (find-class 'command) bbox))
(set-values! b1 'label "normal" 'font f)
(define b2 (create-managed-widget (find-class 'command) bbox))
(set-values! b2 'label "bold" 'font f)
(define b3 (create-managed-widget (find-class 'command) bbox))
(set-values! b3 'label "italic" 'font f)
(define b4 (create-managed-widget (find-class 'command) bbox))
(set-values! b4 'label "faint" 'font f 'sensitive #f)

(define q (create-managed-widget (find-class 'command) box))
(set-values! q 'label "quit" 'border-width 3 'font g)
(add-callback q 'callback (lambda (w) (exit)))

(define q2 (create-managed-widget (find-class 'command) box))
(set-values! q2 'label "apply" 'border-width 3 'font g)
(add-callback q2 'callback (lambda (w) (set! done #t)))

(define done #f)

(realize-widget top)
(while (not done) (context-process-event con))
