60 lines
1.9 KiB
Scheme
60 lines
1.9 KiB
Scheme
|
;;; -*-Scheme-*-
|
||
|
|
;;;
|
||
|
|
;;; Dialog box demo
|
||
|
|
|
||
|
|
(require 'xwidgets)
|
||
|
|
(load-widgets shell ascii dialog command box label)
|
||
|
|
|
||
|
|
(define top (application-initialize 'dialog))
|
||
|
|
(define dpy (widget-display top))
|
||
|
|
|
||
|
|
(define f (open-font dpy "*courier-bold-r-normal--14*"))
|
||
|
|
|
||
|
|
(define gray-bits "\10\2\10\2")
|
||
|
|
(define gray
|
||
|
|
(create-pixmap-from-bitmap-data
|
||
|
|
(display-root-window dpy) gray-bits 4 4
|
||
|
|
(black-pixel dpy) (white-pixel dpy) (display-default-depth dpy)))
|
||
|
|
|
||
|
|
(define bb (create-managed-widget (find-class 'box) top))
|
||
|
|
(define quit (create-managed-widget (find-class 'command) bb 'label "Quit"))
|
||
|
|
(define p (create-managed-widget (find-class 'command) bb 'label "Press me"))
|
||
|
|
(define pshell (create-popup-shell (find-class 'transient-shell) top))
|
||
|
|
(set-values! pshell 'width 150 'height 100)
|
||
|
|
|
||
|
|
(add-callback quit 'callback (lambda _ (exit)))
|
||
|
|
|
||
|
|
(add-callback p 'callback
|
||
|
|
(lambda _
|
||
|
|
(let* ((width (car (get-values top 'width)))
|
||
|
|
(height (car (get-values top 'height)))
|
||
|
|
(pos (widget-translate-coordinates top (truncate (/ width 2))
|
||
|
|
(truncate (/ height 2)))))
|
||
|
|
(set-values! pshell 'x (car pos) 'y (cdr pos)))
|
||
|
|
(set-sensitive! p #f)
|
||
|
|
(set-sensitive! quit #f)
|
||
|
|
(popup pshell 'grab-nonexclusive)))
|
||
|
|
|
||
|
|
(define (dialog-popdown . _)
|
||
|
|
(popdown pshell)
|
||
|
|
(set-sensitive! p #t)
|
||
|
|
(set-sensitive! quit #t))
|
||
|
|
|
||
|
|
(define dialog (create-managed-widget (find-class 'dialog) pshell))
|
||
|
|
(set-values! dialog 'background-pixmap gray)
|
||
|
|
(set-values! dialog 'value "/tmp/test" 'label "Filename:")
|
||
|
|
(set-values! (name->widget dialog 'value) 'font f)
|
||
|
|
|
||
|
|
(define b (create-managed-widget (find-class 'command) dialog 'label "cancel"))
|
||
|
|
(add-callback b 'callback dialog-popdown)
|
||
|
|
|
||
|
|
(define b2 (create-managed-widget (find-class 'command) dialog 'label "write"))
|
||
|
|
(add-callback b2 'callback
|
||
|
|
(lambda (w)
|
||
|
|
(format #t "Filename is ~s~%"
|
||
|
|
(car (get-values (widget-parent w) 'value)))
|
||
|
|
(dialog-popdown)))
|
||
|
|
|
||
|
|
(realize-widget top)
|
||
|
|
(context-main-loop (widget-context top))
|