50 lines
1.5 KiB
Scheme
50 lines
1.5 KiB
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; Pulldown menu demo
|
|
|
|
(require 'motif)
|
|
(load 'menu-stuff.scm)
|
|
|
|
(define top (application-initialize 'pulldown))
|
|
|
|
(define menu-bar (create-menu-bar top))
|
|
|
|
;;; Create pulldown menu pane with 3 push buttons and a sub-menu
|
|
|
|
(define menu-1 (create-pulldown-menu menu-bar))
|
|
|
|
(menu-add-button! menu-1 'label-string "item 1")
|
|
(menu-add-button! menu-1 'label-string "item 2")
|
|
(menu-add-button! menu-1 'label-string "item 3")
|
|
(menu-add-separator! menu-1)
|
|
|
|
(create-cascade-pulldown menu-bar menu-1 'mnemonic #\m 'label-string "menu-1")
|
|
|
|
;;; Create the sub-menu:
|
|
|
|
(define sub-menu (create-pulldown-menu menu-1))
|
|
|
|
(menu-add-label! sub-menu 'label-string "sub-menu")
|
|
(menu-add-separator! sub-menu)
|
|
(menu-add-button! sub-menu 'label-string "item 1")
|
|
(menu-add-button! sub-menu 'label-string "item 2")
|
|
(menu-add-button! sub-menu 'label-string "item 3")
|
|
|
|
(create-cascade-pulldown menu-1 sub-menu 'label-string "sub-menu")
|
|
|
|
;;; Create second pulldown menu width a quit button)
|
|
|
|
(define menu-2 (create-pulldown-menu menu-bar))
|
|
|
|
(menu-add-button! menu-2 'label-string "item 1")
|
|
(menu-add-button! menu-2 'label-string "item 2")
|
|
(menu-add-button! menu-2 'label-string "item 3" 'sensitive #f)
|
|
(menu-add-button! menu-2 'label-string "item 4")
|
|
(menu-add-button! menu-2 'label-string "quit" 'mnemonic #\q
|
|
'activate-callback (list (lambda args (print args) (exit))))
|
|
|
|
(create-cascade-pulldown menu-bar menu-2 'label-string "menu-2")
|
|
|
|
(realize-widget top)
|
|
(context-main-loop (widget-context top))
|