46 lines
1.5 KiB
Scheme
46 lines
1.5 KiB
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; Pulldown menu demo
|
|
|
|
(require 'xaw)
|
|
|
|
(define top (application-initialize 'pulldown))
|
|
|
|
(define mb (create-managed-widget (find-class 'menubutton) top))
|
|
(set-values! mb 'label "Please press left button" 'menu-name 'the-menu)
|
|
|
|
;; Due to a bug in the X11R5 SimpleMenu widget the `label' resource
|
|
;; can only be set at widget creation time:
|
|
;;
|
|
(define menu (create-popup-shell 'the-menu (find-class 'simplemenu) mb
|
|
'label 'menu))
|
|
|
|
(define data "\0\0\0\6\0\3\0\3\200\1\206\1\316\0\314\0\170\0\160\0\40\0\0\0")
|
|
(define bm (create-bitmap-from-data (display-root-window (widget-display top))
|
|
data 12 12))
|
|
|
|
(define (selected w)
|
|
(format #t "~s selected~%" (widget-name w)))
|
|
|
|
(for-each
|
|
(lambda (e)
|
|
(if e
|
|
(if (eqv? e "")
|
|
(create-managed-widget (find-class 'sme) menu 'height 10)
|
|
(create-managed-widget e (find-class 'smebsb) menu
|
|
'vert-space 40 'label e 'callback (list selected)))
|
|
(create-managed-widget (find-class 'smeline) menu)))
|
|
'("hamburger" "fishburger" "pommes frites" "" "chicken nuggets"
|
|
"chicken wings" #f "cola" "milk shake" #f))
|
|
|
|
(define w (create-managed-widget (find-class 'smebsb) menu))
|
|
(set-values! w 'vert-space 50 'left-bitmap bm 'label "eat here"
|
|
'left-margin 16)
|
|
(add-callback w 'callback
|
|
(lambda (w)
|
|
(set-values! w 'left-bitmap
|
|
(if (eq? (car (get-values w 'left-bitmap)) 'none) bm 'none))))
|
|
|
|
(realize-widget top)
|
|
(context-main-loop (widget-context top))
|